@prog #10030 1 999 d 1 i ( Modified by Mouse, 2001-07-22, to support go-chars: character-mapping property. To undo this, remove the "strmap" definition and delete all calls to it; also remove "strmap-setup" [it is used only within strmap]. ) ( Requires .more macro. If you don't have it, do this in the editor: def more { -- } "me" match "More? " notify 1 strcut pop "n" stringcmp not if exit then ) var Board : CenterDist 28 ; : Between? 3 pick >= rot rot >= and ; : SpaceCap " " swap strcat " " strcat ; : AddPrompt "> " swap strcat ; : Tell2 me @ swap notify ; : Tell AddPrompt me @ swap notify ; : Cr " " tell2 ; : TellAll AddPrompt "here" match #-1 rot notify_except ; : RFlush over strlen over >= if pop exit then " " rot strcat swap RFlush ; : LFlush over strlen over >= if pop exit then swap " " strcat swap LFlush ; : Center CenterDist over Strlen 2 / - RFlush ; : GetProp Board @ "*" rot strcat getpropstr ; : KillProp Board @ "*" rot strcat remove_prop ; : SetPropstr Board @ "*" 4 rotate strcat rot 0 addprop ; : PlayerProp "Player-" swap strcat ; : PlayerDB PlayerProp GetProp atoi dbref ; : WhoTurn? "Turn" GetProp PlayerDb ; : BoardSize "Size" GetProp atoi ; ( -- i ) : LineProp "Line-" swap intostr strcat ; ( i -- s ) : ToXY "," explode pop atoi swap atoi ; : ToX,Y intostr swap intostr "," strcat swap strcat ; : GetCoord ( i i -- s ) over 1 BoardSize Between? over 1 BoardSize Between? and not IF pop pop "" ELSE LineProp GetProp swap 1 - 2 * strcut 1 strcut pop swap pop THEN ; : SetCoord ( i i s -- ) swap LineProp dup GetProp 4 rotate 1 - 2 * strcut 1 strcut swap pop 4 rotate swap strcat strcat SetPropstr ; : strmap-setup ( n mapstr ch -- n mapstr' [or] sA sB n+1 mapstr' ) over if swap 1 strcut rot 4 rotate 1 + rot else pop then ; : strmap ( str -- str' ) me @ "go-chars" getpropstr dup if 0 swap "@" strmap-setup "O" strmap-setup "+" strmap-setup "-" strmap-setup pop multisubst else pop then ; : ViewGrid dup LineProp GetProp strmap over intostr 2 RFlush " " strcat swap strcat " " strcat over intostr 2 RFlush strcat Tell dup BoardSize >= if exit then 1 + ViewGrid ; : ViewBoard "@" PlayerDB name Center " @" strmap strcat tell " 1 2 3 4 5 6 7 8 9 11 13 15 17 19" BoardSize 2 * 2 + strcut pop Tell 1 ViewGrid " 1 2 3 4 5 6 7 8 10 12 14 16 18" BoardSize 2 * 2 + strcut pop Tell "O" PlayerDB name Center " O" strmap strcat tell ; : ResetLines dup LineProp "+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+" BoardSize 2 * 1 - strcut pop Setpropstr dup BoardSize >= if pop exit then 1 + ResetLines ; : Reset "@" PlayerProp KillProp "O" PlayerProp KillProp "Capture@" KillProp "CaptureO" KillProp "Turn" KillProp "Pass?" KillProp 1 ResetLines "Game reset by " me @ name strcat "." strcat TellAll ; : Join me @ "@" PlayerDb over Dbcmp "O" PlayerDb rot dbcmp or if "You're already in the game." tell exit then "@" PlayerProp GetProp "O" PlayerProp GetProp and if "Two people are already playing." tell exit then "Turn" "@" SetPropstr "@" PlayerProp GetProp if "O" else "@" then dup PlayerProp me @ intostr SetPropstr me @ name " joins the game as " strcat swap strcat "." strcat TellAll ; : InsertX,Y over over ToX,Y SpaceCap 4 pick over instr 6 pick rot instr or not if over over ToX,Y " " strcat 4 rotate swap strcat rot rot then ; : Surround dup strlen 1 = if pop 1 exit then 1 strcut swap pop dup " " instr 1 - strcut swap ToXY over over GetCoord dup "+" instr if pop pop pop pop pop 0 exit then 8 pick instr if 1 - InsertX,Y 2 + InsertX,Y 1 - swap 1 - swap InsertX,Y swap 2 + swap InsertX,Y swap 1 - swap ToX,Y " " strcat rot swap strcat swap else pop pop then Surround ; : ClearGroup dup not if pop exit then swap ToXY "+" SetCoord 1 - ClearGroup ; : KillGroup 1 strcut swap pop dup strlen 1 - strcut pop " " explode dup intostr " " strcat over 5 + pick strcat "'s were captured." strcat TellAll "Capture" over 5 + pick strcat dup getprop atoi 3 pick + intostr setpropstr ClearGroup ; : CheckForKill over over ToX,Y SpaceCap " " swap Surround if KillGroup then ; : OkToCheck? over over GetCoord 4 pick instr if CheckForKill then ; : Play "," explode 2 - if "Format: Play X,Y" tell exit then atoi dup 1 BoardSize Between? rot atoi dup 1 BoardSize Between? rot and not if "Format: Play X,Y" tell exit then WhoTurn? me @ Dbcmp not if "It's " WhoTurn? name strcat "'s turn to go." strcat tell exit then over over GetCoord "+" strcmp if "A piece had already been placed there." tell exit then over over "Turn" GetProp SetCoord over over ToX,Y me @ name " plays at " strcat swap strcat "." strcat TellAll "Turn" dup Getprop "@" instr if "O" else "@" then SetPropstr "Turn" getprop rot rot 1 - OkToCheck? 2 + OkToCheck? 1 - swap 1 - swap OkToCheck? swap 2 + swap OkToCheck? rot "@" instr if "O" else "@" then rot 1 - rot CheckForKill "It's now " WhoTurn? name strcat "'s turn to play." strcat TellAll "Pass?" KillProp ; : Help "+---------+----------------------+" Tell "| Go v .9 | By: Targhan Solantry |" Tell "+---------+----------------------+" Tell "| Join | Join the game |" Tell "| Leave | Leave the game |" Tell "| Reset | Reset the game |" Tell "| Play | Play a piece |" Tell "| Pass | Pass your turn |" Tell "| Stats | Show game stats |" Tell "| Rules | Read the rules |" Tell "| Help | You figure it out |" Tell "+---------+----------------------+" Tell ; : Leave "@" dup PlayerDb me @ dbcmp not if pop "O" dup PlayerDb me @ dbcmp not if "You haven't joined yet." tell exit then then PlayerProp KillProp me @ name " leaves the game." strcat TellAll ; : Pass WhoTurn? me @ dbcmp not if "It's not your turn." tell exit then me @ name " passes." strcat tellall "Pass?" getprop if "The game is over. You have to count your score yourself since the routine to count scores has not been added yet." tellall exit then "Pass?" "yes" setpropstr ; : Stats "@" PlayerDb Name ":" strcat 17 LFlush "@ " strcat "Enemy Pieces Captured: " strcat "CaptureO" getprop strcat tell "O" PlayerDb Name ":" strcat 17 LFlush "O " strcat "Enemy Pieces Captured: " strcat "Capture@" getprop strcat tell "It is " WhoTurn? name strcat "'s turn to go." strcat tell ; : Rules "Go: Tournament version" Tell2 "~~~ ~~~~~~~~~~ ~~~~~~~" Tell2 "Tournament Go is played by two people on a 19 by 19 board." Tell2 Cr "To start: The board begins empty. Each player starts with an umlimited number" tell2 "of stones." tell2 Cr "The Play: A move consists of placing a stone of your own color on an empty" tell2 "point where two lines on the board intersect. Except for some minor" tell2 "restrictions which I will get to in a minute, play is unrestricted. You can" tell2 "place on any point, including the edges. Once placed, the stones stay put" tell2 "unless comptured. They cannot be moved to other points. You can move or pass" tell2 "on any of your turns, but, in practice, passing only happens near the end of" tell2 "game. When both players pass in succession, the game is over." tell2 Cr "Single Piece Capturing: Go is a game of \"surround and capture.\" A single" tell2 "stone sitting in the middle of an empty board has 4 open points around it." tell2 " +-+-+ All of them are connected by lines to the stone (i.e., no diagonals)" tell2 " +-O-+ These four points are called its \"liberties.\" If all become" tell2 " +-+-+ occupied by enemy forces, that stone is captured. Captured pieces" tell2 "are removed from the board and returned to their owner. Capturing on the edge" tell2 .more " +-+-+-+- +-+-+-+- +-+-+-+- or in the corner is done +-+- +-+-+-+-" Tell2 " +-+-@-+- +-+-@-+- +-+-@-+- similarly using the same +-+- +-+-@-+-" tell2 " +-@-O-@- -> +-@-O-@- -> +-@-+-@- principle of no available O-@- +-@-O-+-" tell2 " +-+-+-+- +-+-@-+- +-+-@-+- liberties." tell2 Cr "Group Capturing: Connected groups of stones may also be +-+- +-+-+-+-" tell2 "captured in much the same way as a single stone. That is, @-+- +-+-@-+-" tell2 "if you are able to surround an entire, connected group so O-@- +-@-O-@-" tell2 "that none of its stones have any liberties available, then" tell2 "the entire group is captured and removed. A connected +-+- +-+-+-+-" tell2 "group, here, is defined as stones that \"touch each other\" @-+- +-+-@-+-" tell2 "with no diagonals permitted. Connected groups live or die +-@- +-@-+-@-" tell2 "as a unit. Individual stones in a group can never be captured individually." tell2 "+-@-O-+-O +-@-O-@-O +-@-+-@-+" tell2 "+-@-O-O-O +-@-O-O-O +-@-+-+-+ Self Capturing: Taking away your own" tell2 "+-+-@-@-@ -> +-+-@-@-@ -> +-+-@-@-@ last liberty is called a \"self capture\"" tell2 "and it's occationally (although rarely) a useful tactic. You remove your" tell2 "suicided piece the same move. +-@-+-O +-@-O-O +-@-+-+" tell2 "pieces the same move. +-@-O-O -> +-@-O-O -> +-@-O-O" tell2 " +-+-@-@ +-+-@-@ +-+-@-@" tell2 .more "Simultaneous Surroundings: If your suicide move simultaneously captures" tell2 "enemy piece(s), then it is a capture move, not suicide, and the enemy pieces" tell2 "are removed. +-+-+-+-+-+ +-+-+-+-+-+ +-+-+-+-+-+" tell2 " +-+-O-@-+-+ +-+-O-@-+-+ +-+-O-@-+-+" tell2 " +-O-+-O-@-+ -> +-O-@-O-@-+ -> +-O-@-+-@-+" tell2 " +-+-O-@-+-+ +-+-O-@-+-+ +-+-O-@-+-+" tell2 cr "(Rules about no repeating)" tell2 ; : Size ( s -- ) (Checks for if a game is in progress) atoi dup 9 19 between? not IF "The board must be between 9 and 19." tell EXIT THEN intostr "Size" over SetPropstr "Board size set to " swap strcat "." TellAll ; : Main Trigger @ Thing? if Trigger @ Board ! ViewBoard exit then Trigger @ location Board ! "Size" Getprop not if "Size" "19" setpropstr then Trigger @ name tolower dup "reset" instr if Reset exit then dup "join" instr if Join exit then dup "help" instr if Help exit then dup "leave" instr if Leave exit then dup "pass" instr if Pass exit then dup "rules" instr if Rules exit then dup "stats" instr if Stats exit then "size" instr if Size exit then Play ; . c q