[wej] - Several wiki pages describe how to handle Forth in Tcl ( [RPN in Tcl], [Trying FORTH in Tcl], [A different Forth], [f4t] ). This page describes a different approach that, following [f4t], aims "to integrate Forth and Tcl as harmonically as possible". TclForth is a Forth system that uses Tcl as its native language. It has the following features. '''Code words''' - The code words are Tcl procs without formal arguments. TclForth replaces the formal argument by a stack diagram. In normal Forth systems the stack notation is a comment that is ignored by the compiler. In TclForth the compiler uses the diagram to add the appropriate stack handling. Example: The Forth word ====== code int ( n1 -- n2 ) set n2 [expr int($n1)] ====== is compiled to ====== proc int {} { set n1 [pop]; set n2 [expr int($n1)]; push $n2 ; } ====== ''' Colon words''' - TclForth is subroutine threaded. As a consequence, the high level colon words are also implemented as Tcl procedures. Example: ====== : Prompt ( -- ) depth 0> withStack and if "$::stack ok>" else "ok>" then Console append update ; ====== becomes ====== proc Prompt {} { depth; 0>; push $::withStack; and; if [pop] { push "$::stack ok>"; } else { push "ok>"; } $::Console insert end [pop]; update; } ====== ''Code procs call Tcl commands, Colon procs call Forth words.'' '''Inner interpreter''' - With subroutine treading the Tcl run time system is the inner interpreter of TclForth. The Forth words are collected in a dictionary implemented as the array Words(). The indices in the array are the Forth word names, the values are compiling scripts. For code and colon words the script inserts the word's name followed by the Tcl separator ";" . '''Flow control''' is handled by '''Compiler words'''. The word ''Prompt'' above illustrates the compiling action of if, else and then. In similar ways TclForth implements all Forth flow words and includes foreach and switch (as a case-of-endof-endcase construct). Other Tcl commands are made available in Forth as compiler words. Example: ====== Compiler doafter appendcode " after \[pop\] \[pop\]; " ====== If you miss a feature, add a compiler word. '''Data words''' are implemented as objecttypes with separate message and method. The objecttypes are compiled as arrays with the messages as names and the methods as scripts. When an object is used in a definition the compiler substitutes "obj" in the method code by the actual object's name. The default message {} is activated when the word following an object is not a valid message of this object. The object then delivers its value. - Definitions, reduced to the messages used in the example: ====== objecttype variable {} {push $obj} set {set obj [pop]} ... ... objecttype string {} {push $obj} ... ... objecttype list append {lappend obj [pop]} length {push [llength $obj]} ... ... ====== Example: ====== : SaveComline ( comline -- ) comline "" != if comline comhistory append comhistory length comindex set then ; ====== is compiled to ====== proc SaveComline {} { set comline [pop]; push $comline; push ""; !=; if [pop] { push $comline; lappend ::comhistory [pop]; push [llength $::comhistory]; set ::comindex [pop]; } } ====== '''Stack Diagram''' - The stack diagram also defines stack-independent local variables for a definition. The syntax is ''( inputs | locals -- results )'' with any number of inputs, locals and results. The local variables are compiled as objecttype variable and can then be casted to other types. Example: ====== : textword ( t | i j -- ) cast t string i t length j set ... ====== '''Tk''' is the true object of desire for Forth programmers. Several attempts to use Tk widgets from a Forth system have been reported, [http://www.rigwit.co.uk/papers/tkforth/index.html%|%TkForth%|%] is still the best documented. Tk has a clear syntax that can be handled in TclForth ''code'' words. There is no pressing need to invent a Forth syntax. However, when packed in TclForth objecttypes the widgets can be handled also in ''colon'' words. - Example: ====== objecttype tkcanvas instance {uplevel #0 {set obj [pop]; canvas $obj} } {} {push $obj} create {eval $obj [concat create [pop]]} text {3swap; eval $obj [concat create text [pop] [pop] -text \"[pop]\"]} config {eval $obj [concat configure [pop]]} rectangle {6swap; eval $obj [concat create rect [pop] [pop] [pop] [pop] -fill [pop] -tag \"[pop]\"]} delete {$obj delete [pop]} polygon {4swap; eval $obj [concat create poly \{[pop]\} -fill [pop] -outline [pop] -tag \"[pop]\"]} scale {5swap; eval $obj [concat scale \"[pop]\" [pop] [pop] [pop] [pop]]} move {3swap; eval $obj [concat move [pop] [pop] [pop]]} bbox {push [$obj bbox [pop]]; unlist} pack {eval [concat pack $obj [pop]]} bind {eval [concat bind $obj [pop]]} bindtag {eval [concat $obj bind [pop]]} find {push [eval $obj find [pop]]} gettags {push [eval $obj gettags [pop]]} dtag {$obj dtag [pop] [pop]} addtag {3swap; $obj addtag [pop] [pop] [pop]} ====== This is made good use of used in the following example program. **Chess in Forth** When I developed TclForth I set out to rebuild Richard Suchenwirth's fine game [http://wiki.tcl.tk/4070%|%Chess in Tcl%|%]. I have not recreated all the game's features, just the parts needed to create and play the game. - The code may serve as an example of '''Postfix Tcl'''. ====== \ File: chess.fth \ Project: TclForth \ Version: 0.2 \ License: Tcl \ Author: Wolf Wejgaard \ \ A Forth version of Richard Suchenwirth's Chess in Tcl -- http://wiki.tcl.tk/4070 \ {} array board {} list history "white" string toMove : reset ( | setup i x y -- ) cast setup list {r n b q k b n r p p p p p p p p . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . P P P P P P P P R N B Q K B N R} setup setlist 0 i set {8 7 6 5 4 3 2 1} {y} foreach {A B C D E F G H} {x} foreach i setup "$x$y" board set i incr repeat repeat "white" toMove set {} history setlist ; : color ( c -- color ) c ascii 97 < if "white" else "black" then color set ; code sameSide? ( a b -- f ) set f [regexp {[a-z][a-z]|[A-Z][A-Z]} $a$b] "white" variable side : coords ( square -- x y ) {} square split y set ascii 64 - x set ; : square ( x y -- sq ) x 64 + char x set "$x$y" sq set ; : valid? ( move | from to fromMan toMan x y x0 y0 x1 y1 dx dy adx ady -- result ) "-" move split to set from set to {} = if 0 return then from board fromMan set to board toMan set fromMan color toMove != if 0 return then fromMan toMan sameSide? if 0 return then from coords y0 set x0 set to coords y1 set x1 set x1 x0 - dup dx set abs adx set y1 y0 - dup dy set abs ady set fromMan tolower "n" != adx not ady not or adx ady = or and if x0 x set y0 y set begin x x1 != y y1 != or while x x0 != y y0 != or x y square board "." != and if 0 return then \ planned path is blocked dx sgn x add dy sgn y add repeat then fromMan tolower case k of adx 2 < ady 2 < and return endof q of adx 0= ady 0= or adx ady = or return endof b of adx ady = return endof n of adx 1 = ady 2 = and adx 2 = ady 1 = and or return endof r of adx 0= ady 0= or return endof endcase fromMan case P of y0 2 = dy 2 = and dy 1 = or dx 0= toMan "." = and and adx 1 = ady 1 = and "p" toMan sameSide? and or return endof p of y0 7 = dy -2 = and dy -1 = or dx 0= toMan "." = and and adx 1 = ady 1 = and "P" toMan sameSide? and or return endof endcase 0 result set ; : validMoves ( from | to move victim -- result ) cast move string cast result list {} result setlist board names {to} foreach "$from-$to" move set move valid? if to board victim set "-$victim" move append move result append then repeat result sort ; {k king q queen b bishop n knight r rook p pawn} array Name {k 0 q 9 b 3.2 n 3 r 5 p 1 . 0} array Value : values ( | square man whitesum blacksum -- result ) board names {square} foreach square board man set man tolower Value man color "white" = if whitesum add else blacksum add then repeat "w:$whitesum b:$blacksum " result set ; : Canvas ( -- ) ".t" tktoplevel top "Chess in Forth" top title "? {console show}" top bind " exit" top bind "$::top.c" tkcanvas w "-height 300 -width 300" w config "-fill both -expand 1" w pack "$::top.f" tkframe frame ; 0 variable info code Panel ( -- ) label $::frame.e -width 30 -anchor w -textvar info -relief sunken button $::frame.u -text Undo -command {undo; drawSetup} button $::frame.r -text Reset -command {reset; drawSetup} button $::frame.f -text Flip -command {flipSides} eval pack [winfo children $::frame] -side left -fill both pack $::frame -fill x -side bottom trace add variable ::toMove write doMoveInfo set ::info "white to move" 0 variable X 0 variable Y {#ffd39b #6e8b3d} list cColors : manPolygon ( man -- shape ) man tolower case b of {-10 8 -5 5 -9 0 -6 -6 0 -10 6 -6 9 0 5 5 10 8 6 10 0 6 -6 10} endof k of {-8 10 -10 1 -3 -1 -3 -3 -6 -3 -6 -7 -3 -7 -3 -10 3 -10 3 -7 6 -7 6 -3 3 -3 3 -1 10 1 8 10} endof n of {-8 10 -1 -1 -7 0 -10 -4 0 -10 6 -10 10 10} endof p of {-8 10 -8 7 -5 7 -2 -1 -4 -5 -2 -10 2 -10 4 -5 2 -1 5 7 8 7 8 10} endof r of {-10 10 -7 1 -10 0 -10 -10 -5 -10 -5 -6 -3 -6 -3 -10 3 -10 3 -6 5 -6 5 -10 10 -10 10 0 7 1 10 10} endof q of {-6 10 -10 -10 -3 0 0 -10 3 0 10 -10 6 10} endof endcase shape set ; 35 variable sqw : center ( x0 y0 x1 y1 -- xc yc ) x0 x1 + 2/ xc ! y0 y1 + 2/ yc ! ; : drawMan ( where what -- ) what "." = if return then what manPolygon what uppercase? if "white" "black" else "black" "gray" then "mv @$where" w polygon "@$where" 0 0 sqw 0.035 * dup w scale "@$where" "$where" w bbox center w move ; : drag ( x y -- ) "current" x X - y Y - w move x X set y Y set ; : bindBoard ( -- ) { drawBoard} w bind {mv <1> "push $::w; push %x; push %y; click"} w bindtag {mv "push %x; push %y; drag"} w bindtag {mv "push %x; push %y; release"} w bindtag ; : drawSetup ( | x y -- ) "mv" w delete 9 1 do 9 1 do I y set J 64 + char x set "$x$y" dup board drawMan loop loop ; : drawBoard ( | x0 x y rows row cols col cIndex tag -- ) cast rows list cast cols list w windowExists if "all" w delete then 15 x0 set x0 x set 5 y set 0 cIndex set 35 sqw set {8 7 6 5 4 3 2 1} rows setlist {A B C D E F G H} cols setlist side "white" != if rows revert cols revert then rows getlist {row} foreach 7 y sqw 2/ + row w text cols getlist {col} foreach x y sqw x add x y sqw + cIndex cColors "square $col$row" w rectangle 1 cIndex - cIndex set repeat x0 x set sqw y add 1 cIndex - cIndex set repeat x0 sqw 2/ - x set 8 y add \ letters go below chess board cols getlist {col} foreach sqw x add x y col w text repeat drawSetup ; : drawChess ( -- ) Canvas Panel w bindBoard reset drawBoard ; : moveInfo ( -- ) "$::toMove to move - [values; pop]" info set ; proc doMoveInfo {- - -} {moveInfo} code getFrom ( w -- from ) $w raise current regexp {@(..)} [$w gettags current] -> from 0 variable From : click ( w cx cy | move victim to fill newfill -- ) cx X set cy Y set w getFrom From set From validMoves {move} foreach "-" move split victim set to set drop w to "-fill" ItemGet fill set fill "green" != fill "red" != and if victim "." = if "green" else "red" then newfill set w to "-fill" newfill ItemPut "$w itemconfigure $to -fill $fill" 1000 doafter then repeat ; : moveMan ( move | to from FromMan -- ToMan ) cast move string "-" move split to set from set from board FromMan set to board ToMan set "-$ToMan" move append FromMan to board set "." from board set move history append toMove "white" = if "black" else "white" then toMove set ; : distance ( xa ya xb yb -- xd yd ) xa xb - xd set ya yb - yd set ; : release ( cx cy | to item tags victim target -- ) cast tags list {} to set "overlap $cx $cy $cx $cy" w find {item} foreach item w gettags tags setlist "square" tags search 0 >= if tags pop to set break then repeat "$::From-$to" valid? if "$::From-$to" moveMan victim set victim tolower "k" = if "Checkmate" info set then "@$to" w delete "@$::From" "current" w dtag "@$to" "withtag" "current" w addtag to target set else From target set \ go back on invalid move then "current" target w bbox center "current" w bbox center distance w move ; : undo ( | from to hit -- ) history length 0= if return then "-" history pop split hit set to set from set to board from board set hit {} = if "." else hit then to board set toMove "white" = if "black" else "white" then toMove set ; : flipSides ( -- ) "all" w delete side "white" = if "black" else "white" then side set drawBoard ; drawChess ====== TclForth is available at [http://tclforth.googlecode.com]. <>Language