taocana: keep in mind that this page can be edited by ANYONE. read the source!
most bare bones playable client:
# use rlwrap for readline functionality
./golem.tcl basic.tcl
move up
move down
move left
move right
say {hello everyone!}
act {eats food}
turnChatbubble right
moveTo {0 0}
see
who
quit
golem.tcl [ files.tcl ... ]
#!/usr/bin/env tclsh8.6
# Creative Commons Zero (CC0)
package require http
package require json
package require tls
namespace eval ::config {
set server play.gikopoi.com
set name golem.tcl
set character onigiri
set password npc
set area for
set room cafe_st
set net_bifpoi 0
set net_warn_unsupported 0
set net_flush_ms 100
set net_poll_ms 5000
set net_ca_dir "/etc/ssl/certs"
}
namespace eval ::state {}
namespace eval ::state::room {}
namespace eval ::scmd {}
namespace eval ::event {
set logged_in {};
set logging_out {};
set joined {}; # uid
set leaving {}; # uid
set moved {}; # uid position direction
set chatted {}; # uid message
set acted {}; # uid action
set changed_inactivity {}; # uid inactive
set chatbubble_turned {}; # uid direction
set character_changed {}; # uid character
set sys_announce {}; # message
}
proc main {} {
set ::state::main_loaded 1
set ::state::logged_in 0
if { ! [ catch { package require Tclx }]} {
signal trap SIGINT { quit "quitting by user request" }
signal trap SIGTERM { quit "process terminated" }
}
::http::register https 443 { ::tls::socket -autoservername true \
-require true -cadir $::config::net_ca_dir }
foreach file $::argv { source $file }
login [ formatLoginData ]
sockShell stdin stdout
# exit via 'quit'
vwait forever
}
proc formatLoginData {} {
dict set d userName [ s $::config::name ]
dict set d characterId [ s $::config::character ]
dict set d areaId [ s $::config::area ]
dict set d roomId [ s $::config::room ]
dict set d password [ s $::config::password ]
return $d
}
proc sockShell { s_in s_out } {
set script "set s_in $s_in ; set s_out $s_out"
append script {
if {[ catch [ gets $s_in ] out ]} {
puts $s_out $::errorInfo
} elseif { $out ne "" } {
puts $s_out $out
}
flush $s_out
}
fileevent $s_in readable $script
}
proc whenever { event arguments body } {
set id [ incr ::state::event_acc ]
dict set $event $id [ list $arguments $body ]
return [ list $event $id ]
}
proc fire { event args } {
dict for { id lambda } $event {
if {[ catch { apply $lambda {*}$args }]} {
puts stderr $::errorInfo
}
}
}
proc disconnect { connection } {
set event [ lindex $connection 0 ]
set id [ lindex $connection 1 ]
dict unset $event $id
return
}
proc map { lambda list } {
set result {}
foreach item $list {
lappend result [ apply $lambda $item ]
}
return $result
}
proc s { txt } { return \"${txt}\" } ; # useful for json, as tcl is untyped
proc xy { d } { list [ dict get $d x ] [ dict get $d y ]}
proc xySum { a b } {
list [ expr {[ lindex $a 0 ] + [ lindex $b 0 ]}] \
[ expr {[ lindex $a 1 ] + [ lindex $b 1 ]}]
}
proc xyDiff { a b } {
list [ expr {[ lindex $a 0 ] - [ lindex $b 0 ]}] \
[ expr {[ lindex $a 1 ] - [ lindex $b 1 ]}]
}
proc assertValidDirection { way } {
switch -- $way {
up return down return left return right return inplace return
default { error "invalid direction: $way" }
}
}
proc offsetToDirection { offset } {
set x [ lindex $offset 0 ]
set y [ lindex $offset 1 ]
if { $y < 0 } { return up } elseif { $y > 0 } { return down }
if { $x > 0 } { return left } elseif { $x < 0 } { return right }
return inplace
}
proc directionToOffset { direction } {
assertValidDirection $direction
switch -- $direction {
up { return {0 -1} } down { return {0 1} }
left { return {1 0} } right { return {-1 0} }
inplace { return {0 0} }
}
}
proc sleep { ms } { after $ms set t 1; vwait t }
proc every { ms body } {
eval $body
after $ms [ namespace code [ info level 0 ]]
}
proc rawRequest { url args } {
# ! ASSUMES USING -command OPTION !
::http::geturl $url -headers "private-user-id $::state::puid" {*}$args
return
}
proc post { url data { type text/plain }} {
rawRequest $url -type $type -query $data -command postCallback
}
proc postCallback { token } {
set err_message [ ::http::error $token ]
set status [ ::http::status $token ]
::http::cleanup $token
if { $status ne "ok" } { error $err_message }
}
proc eio { type { data "" }} {
set id [ switch -- $type {
open { expr 0 }
close { expr 1 }
ping { expr 2 }
pong { expr 3 }
message { expr 4 }
default { error "eio type not known: $type" }
}]
lappend ::state::eio_queue $id$data
if {[ info exists ::state::eio_timer ]} return
set ::state::eio_timer [ after $::config::net_flush_ms flushEio ]
return
}
proc flushEio {} {
set data [ join $::state::eio_queue "\x1e" ]
set ::state::eio_queue [ list ]
catch { unset ::state::eio_timer }
# post last, so it wont cause eventloop problems
post $::state::api$::state::sid $data
}
proc waitForEioFlush {} { vwait ::state::eio_timer }
proc sio { type { data "" }} {
set id [ switch -- $type {
connect { expr 0 }
disconnect { expr 1 }
event { expr 2 }
ack { expr 3 }
connect_error { expr 4 }
default { error "sio type not known: $type" }
}]
eio message $id$data
}
proc cmd { args } { sio event "\[[ join $args , ]\]" }
proc startPolling {} {
rawRequest $::state::api$::state::sid -command pollCallback
}
proc pollCallback { token } {
set data [ ::http::data $token ]
set err_message [ ::http::error $token ]
set status [ ::http::status $token ]
::http::cleanup $token
if { $status ne "ok" } { error $err_message }
foreach packet [ split $data "\x1e" ] { inEio $packet }
tailcall startPolling
}
proc inEio { packet } {
set id [ string index $packet 0 ]
set payload [ string range $packet 1 end ]
switch -- $id {
0 { # open
set data [ ::json::json2dict $payload ]
set ::state::sid &sid=[ dict get $data sid ]
sio connect
}
1 { quit "remote host closing eio socket" ; # close }
2 { eio pong ; # ping }
4 { inSio $payload ; # message }
default { puts "ewhat $packet" }
}
}
proc inSio { packet } {
set packet_type [ string index $packet 0 ]
set payload [ string range $packet 1 end ]
switch -- $packet_type {
0 { set ::state::logged_in 1 ; # connect }
1 { quit "remote host closing sio socket" ; # disconnect }
2 { inCmd {*}[ ::json::json2dict $payload ] ; # event }
default { puts "swhat $packet" }
}
}
proc inCmd { name args } {
if {[ llength [ info procs ::scmd::$name ]] != 1 } {
if { $::config::net_warn_unsupported } {
puts stderr "unsupported cmd: $name"
}
return
}
::scmd::$name {*}$args
}
proc login { data } {
set api [ expr { $::config::net_bifpoi ? "/api" : "" }]
set token [ ::http::geturl https://${::config::server}${api}/login \
-type application/json \
-query [ ::json::dict2json $data ]
]
set login_data [ ::json::json2dict [ ::http::data $token ]]
set err_message [ ::http::error $token ]
set status [ ::http::status $token ]
::http::cleanup $token
if { $status ne "ok" } { error $err_message }
if { ![ dict get $login_data isLoginSuccessful ]} {
error [ dict get $login_data error ]
}
set ::state::uid [ dict get $login_data userId ]
set ::state::puid [ dict get $login_data privateUserId ]
set ::state::api \
https://${::config::server}/socket.io/?EIO=4&transport=polling
set ::state::sid ""
startPolling ; # initial GET for socket.io handshake
vwait ::state::logged_in
if { $::state::logged_in } { fire $::event::logged_in }
}
proc quit {{ reason "" }} {
fire $::event::logging_out
if { $reason ne "" } { puts stderr $reason }
after 4000 exit ; # force if taking too long
sio disconnect
eio close
waitForEioFlush
exit
}
proc updateUser { d } {
set id [ dict get $d id ]
set inactive [ expr {[ dict get $d isInactive ] eq true ? 1 : 0 }]
dict set u name [ dict get $d name ]
dict set u position [ xy [ dict get $d position ]]
dict set u direction [ dict get $d direction ]
dict set u character [ dict get $d characterId ]
dict set u inactive $inactive
set ::state::users($id) $u
}
proc updateRoom { d } {
set ::state::room::id [ dict get $d id ]
set ::state::room::size [ xy [ dict get $d size ]]
set ::state::room::forbids [ list ]
foreach forbid [ dict get $d forbiddenMovements ] {
lappend ::state::room::forbids [ list \
[ list [ dict get $forbid xFrom ] \
[ dict get $forbid yFrom ]] \
[ list [ dict get $forbid xTo ] \
[ dict get $forbid yTo ]]]}
set ::state::room::blocked [ map {{ p } { xy $p }} \
[ dict get $d blocked ]]
set ::state::room::seats [ map {{ p } { xy $p }} [ dict get $d sit ]]
}
proc ::scmd::server-update-current-room-state { d } {
updateRoom [ dict get $d currentRoom ]
foreach user [ dict get $d connectedUsers ] { updateUser $user }
}
proc ::scmd::server-cant-log-you-in {} { quit "server can't log you in" }
proc ::scmd::server-user-joined-room { user_data } {
updateUser $user_data
fire $::event::joined [ dict get $user_data id ]
}
proc ::scmd::server-user-left-room { uid } {
# workaround bug in server that sends 2 leaves
if {[ info exists ::state::users($uid) ]} {
fire $::event::leaving $uid
array unset ::state::users $uid
}
}
proc ::scmd::server-move { d } {
set uid [ dict get $d userId ]
set pos [ xy $d ]
set direction [ dict get $d direction ]
dict set ::state::users($uid) position $pos
dict set ::state::users($uid) direction $direction
fire $::event::moved $uid $pos $direction
}
proc ::scmd::server-msg { uid msg } { fire $::event::chatted $uid $msg }
proc ::scmd::server-roleplay { uid msg } { fire $::event::acted $uid $msg }
proc ::scmd::server-user-active { uid } {
dict set ::state::users($uid) inactive 0
fire $::event::changed_inactivity $uid 0
}
proc ::scmd::server-user-inactive { uid } {
dict set ::state::users($uid) inactive 1
fire $::event::changed_inactivity $uid 1
}
proc ::scmd::server-character-changed { uid character is_alternate } {
dict set ::state::users($uid) character $character
fire $::event::character_changed $uid $character
}
proc ::scmd::server-bubble-position { uid direction } {
dict set ::state::users($uid) chatbubble_direction $direction
fire $::event::chatbubble_turned $uid $direction
}
proc ::scmd::server-system-message { msg } { fire $::event::sys_announce $msg }
proc userInfo { uid info } { dict get $::state::users($uid) $info }
proc setUserInfo { uid info new } { dict set ::state::users($uid) $info $new }
proc searchForUsers { exp } {
set users [ list ]
foreach { uid user } [ array get ::state::users ] {
if {[ regexp -- $exp [ dict get $user name ]]} {
lappend users $uid
}
}
return $users
}
proc searchForOneUser { name } {
set uids [ array names ::state::users ]
set found [ lsearch -exact $uids $name ]
if { $found >= 0 } { return [ lindex $uids $found ]}
set users [ searchForUsers $name ]
if {[ llength $users ] == 1 } { return [ lindex $users 0 ]}
error "couldn't find specific user"
}
proc randomUser {} {
set l [ array names ::state::users ]
lindex $l [ expr {int(rand() * [ llength $l ])}]
}
proc findAdjacentTile { pos } {
foreach way { up down left right } {
set adj_pos [ xySum $pos [ directionToOffset $way ]]
if { ! [ forbiddenMove? $pos $adj_pos ]} { return $adj_pos }
}
error "no adjacent tiles"
}
proc forbiddenMove? { from to } {
set to_x [ lindex $to 0 ]
set to_y [ lindex $to 1 ]
set s_x [ lindex $::state::room::size 0 ]
set s_y [ lindex $::state::room::size 1 ]
expr { $to_x < 0 || $to_x >= $s_x || $to_y < 0 || $to_y >= $s_y
|| [ lsearch -exact $::state::room::blocked $to ] >= 0
|| [ lsearch -exact $::state::room::forbids [ list $from $to ]] >= 0 }
}
proc pathfind { from to } {
# normalize to take advantage of fast string comparison
set from [ list {*}$from ]
set to [ list {*}$to ]
array set visited {}
set paths [ list [ list $from ]]
if {[ forbiddenMove? $to $to ]} { error "no path available "}
while {[ llength $paths ] > 0 } {
foreach path $paths {
set head [ lindex $path end ]
set h_x [ lindex $head 0 ]
set h_y [ lindex $head 1 ]
set visited($head) 1
if { $head eq $to } { return $path }
set adjacents [ list \
[ list [ expr { $h_x - 1 }] $h_y ] \
[ list [ expr { $h_x + 1 }] $h_y ] \
[ list $h_x [ expr { $h_y - 1 }]] \
[ list $h_x [ expr { $h_y + 1 }]]
]
foreach adj $adjacents {
if {[ info exists visited($adj) ]
|| [ forbiddenMove? $head $adj ]} {
continue
}
set new_path $path
lappend new_path $adj
lappend paths $new_path
}
set where [ lsearch -exact $paths $path ]
set paths [ lreplace $paths $where $where ]
}
}
error "no path available"
}
proc pathToMoves { current_face path } {
assertValidDirection $current_face
set current_pos [ lindex $path 0 ]
set path [ lrange $path 1 end ]
set moves [ list ]
foreach tile_pos $path {
set way [ offsetToDirection [ xyDiff $current_pos $tile_pos ]]
if { $current_face ne $way } {
lappend moves $way
set current_face $way
}
lappend moves $way
set current_pos $tile_pos
}
return $moves
}
proc say { txt } { cmd [ s user-msg ] [ s $txt ]}
proc act { txt } { say "/me $txt" }
proc turnChatbubble { way } {
assertValidDirection $way
cmd [ s user-bubble-position ] [ s $way ]
}
proc move { args } {
foreach way $args {
assertValidDirection $way
cmd [ s user-move ] [ s $way ]
}
}
proc moveTo { to } {
set path [ pathfind [ userInfo $::state::uid position ] $to ]
move {*}[ pathToMoves [ userInfo $::state::uid direction ] $path ]
while {[ userInfo $::state::uid position ] ne $to } update
}
# so we can source golem.tcl as it's running
if { ! ([ info exists ::state::main_loaded ] && $::state::main_loaded) } main
basic.tcl
whenever ::event::joined { uid } { puts "[ userInfo $uid name ] joined" }
whenever ::event::leaving { uid } { puts "[ userInfo $uid name ] left" }
whenever ::event::chatted { uid msg } {
if { $msg eq "" } return
puts "[ userInfo $uid name ]: $msg"
}
whenever ::event::acted { uid msg } { puts "* [ userInfo $uid name ] $msg" }
whenever ::event::sys_announce { msg } { puts "!!! $msg !!!" }
whenever ::event::changed_inactivity { uid inactive } {
set txt [ lindex { active inactive } $inactive ]
puts "[ userInfo $uid name ] is now $txt"
}
whenever ::event::character_changed { uid character } {
puts "[ userInfo $uid name ] turned into $character"
}
proc who {} {
foreach { uid } [ searchForUsers .* ] {
puts [ userInfo $uid name ]
}
}
proc see {} {
set s_x [ lindex $::state::room::size 0 ]
set s_y [ lindex $::state::room::size 1 ]
set out ""
for { set y [ expr { $s_y - 1 }] } { $y >= 0 } { incr y -1 } {
for { set x 0 } { $x < $s_x } { incr x } {
set c ". "
set p [ list $x $y ]
if {[ forbiddenMove? $p $p ]} { set c "# " }
if {[ lsearch $::state::room::seats $p ] >= 0 } {
set c "o "
}
foreach user [ searchForUsers .* ] {
if {[ userInfo $user position] eq $p } {
set face [ userInfo $user direction ]
set c "@[string index $face 0]"
}
}
append out $c
}
append out "\n"
}
return $out
}
package require Tk
set pipes [ chan pipe ]
set ::pipe_golem [ lindex $pipes 0 ]
set ::pipe_tk [ lindex $pipes 1 ]
text .script
button .eval -text "evaluate" -command {
puts $::pipe_tk [ .script get 1.0 end ]
flush $::pipe_tk
}
pack .script
pack .eval
sockShell $::pipe_golem stdout
tts.tcl
whenever ::event::joined { uid } { speak "[ userInfo $uid name ] joined" }
whenever ::event::leaving { uid } { speak "[ userInfo $uid name ] left" }
whenever ::event::chatted { uid msg } {
if { $msg eq "" } return
speak "[ userInfo $uid name ]: $msg"
}
whenever ::event::acted { uid msg } { speak "* [ userInfo $uid name ] $msg" }
whenever ::event::sys_announce { msg } { speak "!!! $msg !!!" }
whenever ::event::changed_inactivity { uid inactive } {
set txt [ lindex { active inactive } $inactive ]
speak "[ userInfo $uid name ] is now $txt"
}
whenever ::event::character_changed { uid character } {
speak "[ userInfo $uid name ] turned into $character"
}
proc speak { txt } { exec flite -t $txt & }
annoy.tcl
set ::state::annoyee ""
proc annoy {{ uid "" }} {
set ::state::annoyee $uid
doAnnoying
}
proc doAnnoying {} {
if { $::state::annoyee eq "" } return
set pos [ userInfo $::state::annoyee position ]
moveTo $pos
moveTo [ findAdjacentTile $pos ]
tailcall doAnnoying
}
tkcmd.tcl
package require Tk
set pipes [ chan pipe ]
set ::pipe_golem [ lindex $pipes 0 ]
set ::pipe_tk [ lindex $pipes 1 ]
text .script
button .eval -text "evaluate" -command {
puts $::pipe_tk [ .script get 1.0 end ]
flush $::pipe_tk
}
pack .script
pack .eval
sockShell $::pipe_golem stdout