#! xbigforth
\ automatic generated code
\ do not edit

also editor also minos also forth

menu-component class go
public:
  infotextfield ptr white
  infotextfield ptr black
  infotextfield ptr white#
  infotextfield ptr black#
  infotextfield ptr handicap
  text-label ptr comment
  canvas ptr go-field
 ( [varstart] ) 19 dup * var field
$100 var fpad
cell var goin
cell var goout
cell var taskid
cell var done
method go-task
method new-game
method close-game
method go-write ( [varend] ) 
how:
  : params   DF[ 0 ]DF X" Go" ;
class;

component class file-menu
public:
 ( [varstart] )  ( [varend] ) 
how:
  : params   DF[ 0 ]DF X" No Title" ;
class;

component class help-menu
public:
 ( [varstart] )  ( [varend] ) 
how:
  : params   DF[ 0 ]DF X" No Title" ;
class;

component class go-game-menu
public:
 ( [varstart] )  ( [varend] ) 
how:
  : params   DF[ 0 ]DF X" No Title" ;
class;

go-game-menu implements
 ( [methodstart] )  ( [methodend] ) 
  : widget  ( [dumpstart] )
        ^^ S[ s" pass" go go-write ]S ( MINOS ) X" Pass" menu-entry new 
        ^^ S[ s" resign" go go-write ]S ( MINOS ) X" Resign" menu-entry new 
      #2 vabox new #2 borderbox
    ( [dumpend] ) ;
class;

help-menu implements
 ( [methodstart] )  ( [methodend] ) 
  : widget  ( [dumpstart] )
        ^^ S[  ]S ( MINOS ) X" About" menu-entry new 
        ^^ S[  ]S ( MINOS ) X" Contents" menu-entry new 
      #2 vabox new #2 borderbox
    ( [dumpend] ) ;
class;

file-menu implements
 ( [methodstart] )  ( [methodend] ) 
  : widget  ( [dumpstart] )
        ^^ S[ [ also dos ]
  go close-game
  go new-game
[ previous ] ]S ( MINOS ) X" New Game" menu-entry new 
        ^^ S[ go close ]S ( MINOS ) X" Exit" menu-entry new 
      #2 vabox new #2 borderbox
    ( [dumpend] ) ;
class;

go implements
 ( [methodstart] ) also DOS
: go-write ( addr u -- )
  ( 2dup type cr ) goin @ write-line throw ;
: go-line ( addr u field -- )
  >r 4 /string r> 19 bounds ?DO
    over c@ 0 swap
    CASE  'O OF  1+  ENDOF
          'X OF  1-  ENDOF
    ENDCASE  >r over 1+ c@ r> swap ') = IF 2* THEN  I c!
    2 /string  LOOP  2drop ;
: prefix? ( addr1 u1 addr2 u2 -- flag )
  tuck 2>r min 2r> compare 0= ;
: eval-line ( addr u -- )  \ dup IF  2dup type cr  THEN
  2dup s" Game over." prefix?  IF  1 done !  EXIT  THEN
  2dup s" White("  prefix? IF  comment assign  EXIT  THEN
  2dup s" white("  prefix? IF  comment assign  EXIT  THEN
  2dup s" Black("  prefix? IF  comment assign  EXIT  THEN
  2dup s" black("  prefix? IF  comment assign  EXIT  THEN
  2dup s" GNU Go"  prefix? IF  comment assign  EXIT  THEN
  2dup s" Result:" prefix? IF  comment assign  EXIT  THEN
  2dup s"     White has captured " prefix?
  IF 23 /string 0. 2swap >number 2drop white assign EXIT THEN
  2dup s"     Black has captured " prefix?
  IF 23 /string 0. 2swap >number 2drop black assign EXIT THEN
  2dup s"     aprox. White territory: " prefix?
  IF 28 /string 0. 2swap >number 2drop white# assign EXIT THEN
  2dup s"     Estimated score: White " prefix?
  IF 39 /string 0. 2swap >number 2drop white# assign
                                    0. black# assign EXIT THEN
  2dup s"     aprox. Black territory: " prefix?
  IF 28 /string 0. 2swap >number 2drop black# assign EXIT THEN
  2dup s"     Estimated score: Black " prefix?
  IF 39 /string 0. 2swap >number 2drop black# assign 
                                    0. white# assign EXIT THEN
  over 3 bl skip 0. 2swap >number 0=
  IF 2drop dup >r 19 swap - 19 * field + go-line
     r> 1 = IF  go-field draw done @ negate done !  THEN
     EXIT  THEN
  drop 2drop 2drop ;
: close-game
  goin  @ IF  goin  @ close-file throw
              s" /tmp/goin" delete-file throw  THEN
  goout @ IF  goout @ close-file throw
              s" /tmp/goout" delete-file throw  THEN
  goin off  goout off ;
: go-task ( -- )  done off  taskid @ ?dup IF  kill  THEN
  ^ 1 $1000 dup NewTask dup taskid ! pass op! decimal
  BEGIN  $100 0 DO  BEGIN  fpad I + 1 goout @ read-file
                    WHILE  drop goout @ filehandle @ #5000 idle
                    REPEAT  drop fpad I + c@ #lf <> WHILE
         LOOP  fpad $100  ELSE  fpad I  UNLOOP  THEN
  eval-line done @ 0< UNTIL close-game taskid off ;
Variable go$
: new-game base push decimal
  go field 19 dup * erase go-field draw
  0" mknod /tmp/goin p" dup >len type cr system drop
  0" mknod /tmp/goout p" dup >len type cr system drop
  s" gnugo --mode ascii --handicap " go$ $!
  handicap get tuck dabs <# #S #> go$ $+!
  0< IF s"  --color white" go$ $+! THEN
  s"  </tmp/goin >/tmp/goout 2>/dev/null & " go$ $+!
  go$ $@ 2dup + 1- 0 swap c! drop dup >len type cr system drop
  s" /tmp/goin" w/o open-file throw goin !
  s" /tmp/goout" r/o nonblock open-file throw goout !
  go-task
  s" score" go-write ;
: close  close-game super close ;
previous ( [methodend] ) 
  : widget  ( [dumpstart] )
        M: file-menu menu X"  File " menu-title new 
        M: go-game-menu menu X"  Game " menu-title new 
        $1 $1 *hfilll $1 $1 *vfilll rule new 
        M: help-menu menu X"  Help " menu-title new 
      #4 hbox new vfixbox  #2 borderbox
            #0. ]N ( MINOS ) ^^ SN[  ]SN ( MINOS ) X" Captured: White" infotextfield new  ^^bind white
            #0. ]N ( MINOS ) ^^ SN[  ]SN ( MINOS ) X" Black" infotextfield new  ^^bind black
          #2 hatab new #1 hskips
            #0. ]N ( MINOS ) ^^ SN[  ]SN ( MINOS ) X" Territory: White" infotextfield new  ^^bind white#
            #0. ]N ( MINOS ) ^^ SN[  ]SN ( MINOS ) X" Black" infotextfield new  ^^bind black#
          #2 hatab new #1 hskips
            #0. ]N ( MINOS ) ^^ SN[  ]SN ( MINOS ) X" Handicap" infotextfield new  ^^bind handicap
            ^^ S[ s" pass" go-write ]S ( MINOS ) X" Pass" button new 
            ^^ S[ s" back" go-write
s" back" go-write ]S ( MINOS ) X" Back" button new 
          #3 habox new vfixbox  #1 hskips
          X" " text-label new  ^^bind comment
        #4 vabox new vfixbox  panel
          CV[ 38 dup steps $C0 dup dup rgb> backcolor clear
1 1 home! path
9 0 DO  0 -36 to 2 0 to 0 36 to 2 0 to  LOOP
0 -36 to
9 0 DO  -36 0 to 0 2 to 36 0 to 0 2 to  LOOP
-36 0 to stroke up 1 1 textpos 6 -30 to
3 0 DO
    3 0 DO  icon" icons/black-marker" icon  12 0 to  LOOP
    -36 12 to  LOOP  -6 -6 to
dpy with field endwith
19 dup * bounds ?DO
   I 19 bounds ?DO  I cx@
      CASE  1 OF  icon" icons/white-dot"  icon  ENDOF 
            2 OF  icon" icons/white-last" icon  ENDOF 
           -1 OF  icon" icons/black-dot"  icon  ENDOF 
           -2 OF  icon" icons/black-last" icon  ENDOF 
      ENDCASE
      2 0 to  LOOP
   -38 -2 to 19 +LOOP
down ]CV ( MINOS ) ^^ CK[ ( x y b n -- ) dup 2 <> IF  2drop 2drop  EXIT  THEN
base push decimal
taskid @ 0= IF  new-game  THEN
2drop go-field xywh 2>r p- 2r> rot swap
19 swap */ >r 19 swap */ r>
19 swap - 0 <# #S rot 'a + dup 'i >= IF  1+  THEN  hold #>
goin @ IF  2dup go-write
THEN  2drop ]CK ( MINOS ) $130 $1 *hfil $130 $1 *vfil canvas new  ^^bind go-field
        #1 habox new
      #2 vabox new
    ( [dumpend] ) ;
class;

: main
  go open-app
  event-loop bye ;
script? [IF]  main  [THEN]
previous previous previous
