home *** CD-ROM | disk | FTP | other *** search
/ AMIGA PD 1 / AMIGA-PD-1.iso / Programme_zum_Heft / Programmieren / Kurztests / ACE / Prgs / games / stratego.b < prev    next >
Text File  |  1994-10-26  |  34KB  |  1,775 lines
  1. ' Serial Stratego
  2. ' Written by: Daniel Oberlin
  3.  
  4. DECLARE FUNCTION ActivateWindow LIBRARY intuition
  5. DECLARE FUNCTION SetWindowTitles LIBRARY intuition
  6.  
  7. ' Some variables that should be integers.
  8. SHORTINT i, j, m0, m1, messmenu, rule1, rule2
  9. SHORTINT movenum, gturn, ourcolor
  10. SHORTINT px, pxa, pxb, py, pya, pyb, pn, pn2, pna, pnb
  11. SHORTINT bx1, by1, bx2, by2, bc
  12. SHORTINT blocked, attack, correct, jump
  13.  
  14. ' Set up initial variables and arrays.
  15. DIM board(9,9), captured(12)
  16. DIM message$(20) : DIM mmessage$(20) : DIM pack%(300) : DIM upack%(8) : DIM fnk$(10)
  17. pc$="123456789S*F  ?+" : num$="0123456789" : vtcode$="HKJr" : messmenu = 5
  18. first% = 63 : null$ = CHR$(1)+CHR$(1)+CHR$(1)+CHR$(1)+CHR$(1)
  19. DIM messbuf$(30) : DIM macro$(10) : for i=1 to 20 : message$(i) = chr$(0) : mmessage$(i) = chr$(0) : next i
  20. screenstat% = -3 : intro%=0
  21. version$ = "Version 1.5"
  22.  
  23. ' This stuff is for the sound subroutines.
  24. declare function xRead&    library
  25. const maxsample=131070, channel=1, CHIP=0, MAXCHIP=2
  26. longint offset&, per&, numsound%
  27. dim wave_ptr&(100)
  28. dim samples_per_second&(10), sz&(10), buffer&(10)
  29. dim soundfile$(10)
  30.  
  31. ' Load preferences.
  32. OPEN "I",2,"stratego.prefs"
  33. IF err<>0 THEN ERMSG$="Error opening preferences file." : GOTO Errr
  34. INPUT #2, baud%
  35. INPUT #2, serstr$
  36. INPUT #2, serdev$
  37. INPUT #2, commod$
  38. INPUT #2, hangup$
  39. INPUT #2, seruni%
  40. INPUT #2, spkdev$
  41. INPUT #2, delim$
  42. INPUT #2, opt%
  43. CLOSE #2
  44.  
  45. ' Load user macros.
  46. OPEN "I",2,"stratego.macros"
  47. IF err<>0 THEN ERMSG$="Error opening preferences file." : GOTO Errr
  48. FOR mac%=1 TO 10
  49. LINE INPUT #2, macro$(mac%)
  50. NEXT mac%
  51. CLOSE #2
  52.  
  53. ' Load sounds.
  54. IF (opt% AND 2) = 0 THEN
  55. numsound%=5
  56. soundfile$(1)="sounds/click.snd"
  57. soundfile$(2)="sounds/ping.snd"
  58. soundfile$(3)="sounds/bomb.snd"
  59. soundfile$(4)="sounds/haha.snd"
  60. soundfile$(5)="sounds/win.snd"
  61. GOSUB Readiffsounds
  62. END IF
  63.  
  64. ' Open Devices
  65. OPEN "O", 3, spkdev$
  66. IF err<>0 THEN ERMSG$="Error opening speak device." : GOTO Errr
  67. screenstat% = -2
  68.  
  69. SERIAL OPEN 1,seruni%,baud%,serstr$,1024,serdev$
  70. IF err<>0 THEN ERMSG$="Error opening serial device." : CLOSE 3 : GOTO Errr
  71. screenstat% = -1
  72.  
  73. ' Open terminal screen.
  74. SCREEN 1, 640, 200, 1, 2
  75. WINDOW 1, , (0,13)-(640,200) , 32, 1
  76. SetWindowTitles(window(7),-1&,"Serial Stratego "+version$+"   "+"Baud Rate:"+str$(baud%)+" Serial Settings: "+serstr$)
  77.  
  78. screenstat% = 0
  79.  
  80. Restart:
  81. SCREEN FORWARD 1
  82. WINDOW OUTPUT 1
  83.  
  84. GOSUB Inittermmenu
  85.  
  86. ActivateWindow(window(7))
  87.  
  88. PALETTE 0, 0, 0, 0
  89. PALETTE 1, 1, 1, 1
  90.  
  91. FONT "topaz", 8
  92.  
  93. IF intro%=0 THEN
  94.   CLS
  95.   PRINT
  96.   PRINT "Welcome to Serial STRATEGO ";version$;"      Written By: Daniel Oberlin"
  97.   PRINT 
  98.   PRINT "Now in terminal mode."
  99.   PRINT "Establish link and use the Setup menu to begin the game."
  100.   PRINT
  101.   intro% =1
  102. END IF
  103.  
  104. ' Do Terminal Loop here.
  105. m0 = 0 : m1 = 0
  106. ON MENU GOSUB Termmenuhandler
  107. MENU ON
  108.  
  109. chars% = serial(1,0) : serial read 1, b$, chars%
  110.  
  111. Terminaloop:
  112. IF (opt% AND 1) = 0 THEN SLEEP
  113. a$ = INKEY$
  114. IF a$<>"" then serial write 1, a$, 1 : a$=""
  115. chars% = serial(1,0)
  116. IF chars%<>0 THEN serial read 1, b$, chars% : PRINT b$; : b$ = ""
  117.  
  118. IF m0 = 1 THEN
  119.   m0 = 0
  120.   IF m1 = 3 THEN
  121.     SLEEP FOR 1
  122.     serial write 1, commod$, len(commod$)
  123.     SLEEP FOR 1
  124.     serial write 1, hangup$+chr$(13), len(hangup$)+1
  125.     GOTO Terminaloop
  126.   END IF
  127.   IF m1 = 4 THEN
  128.     GOSUB Closeall
  129.     STOP
  130.   END IF
  131.   IF m1 = 1 THEN
  132.     ourcolor = 0
  133.     GOTO Newgame
  134.   ELSE
  135.     ourcolor = 1
  136.     GOTO Newgame
  137.   END IF
  138. END IF
  139.  
  140. IF m0 = 2 THEN
  141.   serial write 1, macro$(m1)+CHR$(13), LEN(macro$(m1))+1
  142.   m0 = 0
  143. END IF
  144.  
  145. GOTO Terminaloop
  146. MENU OFF
  147.  
  148.  
  149. ' Begin a new game.
  150. Newgame:
  151. opx% = -1 : opy% = -1
  152. gturn  = 1 : rturn% = -1 : lockboard% = 0 : opready% = 0 : gameover% = 0 : m0 = 0 : m1 = 0
  153. movenum  = 0 : rule1 = 0 : rule2 = 1 : ourmess% = 1 : thermess% = 1 : recmode% = 1 : mstat% = 0
  154. FOR i=1 TO 12 : captured(i) = 0 : NEXT i
  155.  
  156. IF screenstat%=0 THEN
  157.   SCREEN 2, 320, 200, 3, 1
  158. END IF
  159. PALETTE 0, 0, 0, 0
  160. PALETTE 1, 1, 1, 1
  161. IF ourcolor = 0 THEN
  162.   PALETTE 2, 0, 0, 1
  163.   PALETTE 4, 1, 0, 0
  164. ELSE
  165.   PALETTE 4, .4, .4, 1
  166.   PALETTE 2, 1, 0, 0
  167. END IF
  168. PALETTE 3, 0, 1, 0
  169. PALETTE 5, .5, 0, 0
  170. PALETTE 6, 0, 0, .5
  171. IF screenstat%=0 THEN
  172.   WINDOW 2, "Info", (176, 13)-(311, 188), 16, 2
  173.   FONT "topaz", 8
  174.   WINDOW 3, "Game Board", (0, 13)-(175, 194), 16, 2
  175.   FONT "topaz", 8
  176.   screenstat% = 1
  177. END IF
  178.  
  179. WINDOW OUTPUT 2
  180. CLS
  181. PRINT
  182. PRINT "Setup board."
  183. WINDOW OUTPUT 3
  184. ActivateWindow(window(7))
  185. SetWindowTitles(window(7),-1&,"Serial Stratego "+version$)
  186. SCREEN FORWARD 2
  187.  
  188. ' Load and draw the board.
  189. file$ = "stratego.data"
  190. GOSUB Loadboard
  191. GOSUB Drawboard
  192. WINDOW OUTPUT 3
  193. GOSUB Initmenu
  194.  
  195.  
  196. ' Let the player switch pieces around to set up
  197. Switchpiece:
  198. lockboard% = 0
  199. GOSUB Gwait
  200. IF m0 = 1 THEN
  201.   m0 = 0
  202.   IF m1 = 1 THEN GOTO Donesetup
  203.   GOTO Switchpiece
  204. END IF
  205. IF rturn% > -1 THEN
  206.   WINDOW OUTPUT 2
  207.   PRINT
  208.   PRINT "No cheating."
  209.   WINDOW OUTPUT 3
  210.   GOTO Switchpiece
  211. END IF
  212. lockboard% = 1
  213. pxa = px
  214. pya = py
  215. pn = board(pxa, pya)
  216. IF pn>12 THEN GOTO Switchpiece
  217. bc = 1
  218. GOSUB Putpiece
  219.  
  220. IF (opt% AND 2) = 0 THEN
  221. sn% = 1
  222. GOSUB Playsound
  223. END IF
  224.  
  225. Switchpiece2:
  226. GOSUB Gwait
  227. pxb = px
  228. pyb = py
  229. pn2 = board(pxb, pyb)
  230. IF pn2>12 THEN GOTO Switchpiece2
  231. board(pxb, pyb) = pn : board (pxa, pya) = pn2
  232. bc = 0
  233. px = pxb : py = pyb : pn = board(pxb, pyb) : GOSUB Putpiece
  234. px = pxa : py = pya : pn = board(pxa, pya) : GOSUB Putpiece
  235. IF (opt% AND 2) = 0 THEN
  236. sn% = 1
  237. GOSUB Playsound
  238. END IF
  239. GOTO Switchpiece
  240.  
  241.  
  242. ' Done setting up.  Wait for opponent to set up.
  243. Donesetup:
  244. lockboard% = 2
  245. send$ = "OK"
  246. GOSUB Sendit
  247. IF opready% = 0 THEN
  248.   WINDOW OUTPUT 2
  249.   PRINT
  250.   PRINT "Wait for setup."
  251.   WINDOW OUTPUT 3
  252.   gturn = 0
  253.   GOSUB Gwait
  254.   IF opready% = 0 THEN
  255.     WINDOW OUTPUT 2
  256.     PRINT
  257.     PRINT "FATAL:"
  258.     PRINT "Error #1"
  259.     WINDOW OUTPUT 3
  260.   END IF
  261. ELSE
  262.   GOSUB Sancheck
  263. END IF
  264.  
  265. movenum = 1
  266.  
  267.  
  268. IF rturn% = -1 AND ourcolor = 1 THEN GOTO Theirturn
  269. IF rturn% = 0 THEN GOTO Theirturn
  270.  
  271. ' It is now our turn.
  272. Ourturn:
  273. gturn = 1 : rturn% = 1
  274. WINDOW OUTPUT 2
  275. PRINT
  276. PRINT "Move #";movenum
  277. PRINT "It is your turn."
  278. WINDOW OUTPUT 3
  279.  
  280. Whichpiece:
  281. GOSUB Gwait
  282. IF m0 = 3 AND m1 = 2 THEN
  283.   m0 = 0
  284.   send$ = "CON"
  285.   GOSUB Sendit
  286.   WINDOW OUTPUT 2
  287.   PRINT : PRINT "You lose."
  288.   WINDOW OUTPUT 3
  289.   IF (opt% AND 2) = 0 THEN
  290.   sn% = 4
  291.   GOSUB Playsound
  292.   END IF
  293.   GOTO Finish
  294. END IF
  295.  
  296. pxa = px
  297. pya = py
  298. pn = board(pxa, pya)
  299. pna = pn
  300. IF pn<1 OR pn>10 THEN GOTO Whichpiece
  301. bc = 1 : GOSUB Putpiece
  302.  
  303. IF opx%<>-1 THEN
  304.   bc = 2 : pn = 13 : px = opx% : py = opy% : GOSUB Putpiece
  305.   opx% = -1 : opy% = -1
  306. END IF
  307.  
  308. IF (opt% AND 2) = 0 THEN
  309. sn% = 1
  310. GOSUB Playsound
  311. END IF
  312.  
  313. Wherego:
  314.  
  315. GOSUB Gwait
  316. pxb = px
  317. pyb = py
  318. pn = board(pxb, pyb)
  319. pnb = pn
  320.  
  321. IF pxa = pxb AND pya = pyb THEN
  322.   bc = 0
  323.   GOSUB Putpiece
  324.   IF (opt% AND 2) = 0 THEN
  325.   sn% = 1
  326.   GOSUB Playsound
  327.   END IF
  328.   GOTO Whichpiece
  329. END IF
  330.  
  331. IF pnb<13 THEN GOTO Wherego
  332. IF pna = 9 THEN GOTO Scoutmove
  333.  
  334. IF pxa = pxb AND pya = pyb + 1 THEN GOTO Okhere
  335. IF pxa = pxb AND pya = pyb - 1 THEN GOTO Okhere
  336. IF pya = pyb AND pxa = pxb + 1 THEN GOTO Okhere
  337. IF pya = pyb AND pxa = pxb - 1 THEN GOTO Okhere
  338.  
  339. GOTO Wherego
  340.  
  341. Scoutmove:
  342.  
  343. blocked = 0
  344. correct = 0
  345. jump = 0
  346.  
  347. IF pxa = pxb then
  348.   correct = 1
  349.   IF pya > pyb THEN    
  350.     FOR i = (pyb+1) TO (pya-1)
  351.     IF board(pxa, i) <> 14 THEN blocked = 1
  352.     jump = 1
  353.     NEXT i
  354.   ELSE
  355.     FOR i = (pya+1) TO (pyb-1)
  356.     IF board(pxa, i) <> 14 THEN blocked = 1
  357.     jump = 1
  358.     NEXT i
  359.   END IF
  360. END IF
  361.  
  362. if pya = pyb then
  363.   correct = 1
  364.   IF pxa > pxb THEN
  365.     FOR i = (pxb+1) TO (pxa-1) 
  366.     IF board(i, pya) <> 14 THEN blocked = 1
  367.     jump = 1
  368.     NEXT i
  369.   ELSE
  370.     FOR i = (pxa+1) TO (pxb-1)
  371.     IF board(i, pya) <> 14 THEN blocked = 1
  372.     jump = 1
  373.     NEXT i
  374.   END IF
  375. end if
  376.  
  377. IF correct = 0 OR blocked = 1 THEN GOTO Wherego
  378.  
  379. IF pnb = 13 AND rule1 = 0 AND jump = 1 THEN GOTO Wherego
  380.    
  381. Okhere:
  382.  
  383. send$ = ""
  384. IF pnb = 13 THEN
  385.   attack = 1
  386.   send$ = "A"
  387. ELSE
  388.   attack = 0
  389.   send$ = "M"
  390. END IF
  391.  
  392. send$ = send$ + MID$(num$, pxa+1, 1) + MID$(num$, pya+1, 1) + MID$(num$, pxb+1, 1) + MID$(num$, pyb+1, 1) 
  393.  
  394. IF attack = 1 THEN
  395.  
  396.   send$ = send$ + MID$(pc$, pna, 1)
  397.   GOSUB Sendit
  398.   pnb = 15 : px = pxb : py = pyb : pn = pnb : bc = 3 : GOSUB Putpiece
  399.  
  400.  
  401.   gturn = 0  
  402.   GOSUB Gwait
  403.   gturn = 1
  404.  
  405.   rec$ = RIGHT$(rec$,1)
  406.     
  407.   GOSUB Piecenum
  408.   
  409.   px = pxb : py = pyb : pn = pnb : bc = 3 : GOSUB Putpiece
  410.  
  411.   IF (opt% AND 2) = 0 THEN
  412.   sn% = 2
  413.   GOSUB Playsound
  414.   END IF
  415.  
  416.   IF pnb = 11 AND pna <> 8 THEN
  417.     IF (opt% AND 2) = 0 THEN
  418.     SLEEP FOR .25
  419.     sn% = 3
  420.     GOSUB Playsound
  421.     END IF
  422.   END IF
  423.  
  424.   IF pnb = 12 THEN
  425.     WINDOW OUTPUT 2
  426.     PRINT : PRINT "You WIN!!!"
  427.     WINDOW OUTPUT 3
  428.     IF (opt% AND 2) = 0 THEN
  429.     sn% = 5
  430.     GOSUB Playsound
  431.     END IF
  432.     captured(12) = captured(12) + 1 : GOTO Finish 
  433.   END IF
  434.     
  435.   GOSUB Swait
  436.  
  437.   CASE
  438.   pna = 10 AND pnb = 1: board(pxa, pya) = 14 : board(pxb, pyb) = pna : captured(1) = captured(1) + 1 : goto elabel1
  439.   pnb = 11 AND pna = 8: board(pxa, pya) = 14 : board(pxb, pyb) = pna : captured(11) = captured(11) + 1 : goto elabel1
  440.   pnb = 11 AND pna <>8: board(pxa, pya) = 14 : goto elabel1
  441.   pna = pnb: board(pxa, pya) = 14 : board(pxb, pyb) = 14 : captured(pna) = captured(pna) + 1 : goto elabel1
  442.   pna < pnb: board(pxb, pyb) = pna : board(pxa, pya) = 14 : captured(pnb) = captured(pnb) + 1 : goto elabel1
  443.   END CASE
  444.  
  445.   IF rule2 = 0 THEN
  446.     board(pxa, pya) = 14
  447.   ELSE
  448.     board(pxa, pya) = 13
  449.     board(pxb, pyb) = 14
  450.   END IF
  451.  
  452. elabel1:
  453.  
  454. ELSE
  455.   
  456.   GOSUB Sendit
  457.   
  458.   board(pxb, pyb) = pna
  459.   board(pxa, pya) = 14
  460.  
  461. END IF
  462.  
  463. pn = board(pxa, pya)
  464. IF pn = 13 THEN
  465.   bc = 2
  466. ELSE
  467.   bc = 0
  468. END IF
  469. px = pxa : py = pya : GOSUB Putpiece
  470.  
  471. pn = board(pxb, pyb)
  472. IF pn= 13 THEN
  473.   bc = 2
  474. ELSE
  475.   bc = 0
  476. END IF
  477. px = pxb : py = pyb : GOSUB Putpiece
  478. IF (opt% AND 2) = 0 THEN
  479. sn% = 1
  480. GOSUB Playsound
  481. END IF
  482.  
  483.  
  484. movenum = movenum +1
  485.  
  486.  
  487. ' It is now their turn.
  488. Theirturn:
  489. gturn = 0 : rturn% = 0
  490.  
  491. WINDOW OUTPUT 2
  492. PRINT
  493. PRINT "Move #";movenum
  494. PRINT "Waiting..."
  495. WINDOW OUTPUT 3
  496.  
  497. GOSUB Gwait
  498.  
  499. IF rec$="CON" THEN
  500.   WINDOW OUTPUT 2
  501.   PRINT : PRINT "Opponent" : PRINT "concedes:" : PRINT "You WIN!!!"
  502.   WINDOW OUTPUT 3
  503.   IF (opt% AND 2) = 0 THEN
  504.   sn% = 5
  505.   GOSUB Playsound
  506.   END IF
  507.   GOTO Finish
  508. END IF
  509.  
  510. pxb = 9 - VAL(MID$(rec$, 2, 1)) : pyb = 9 - VAL(MID$(rec$, 3, 1)) : pxa = 9 - VAL(MID$(rec$, 4, 1)) : pya = 9 - VAL(MID$(rec$, 5, 1)) 
  511. pna = board(pxa, pya)
  512.  
  513. IF LEFT$(rec$, 1) = "A" THEN
  514.   attack = 1
  515. ELSE
  516.   attack = 0
  517. END IF
  518.  
  519. IF attack = 1 THEN
  520.  
  521.   rec$ = RIGHT$(rec$, 1) : GOSUB Piecenum
  522.  
  523.  
  524.   px = pxb : py = pyb : pn = pnb : bc = 3 : GOSUB Putpiece
  525.   px = pxa : py = pya : pn = pna : bc = 1 : GOSUB Putpiece
  526.  
  527.   send$ = "V"+MID$(pc$, board(pxa, pya), 1)
  528.   GOSUB Sendit
  529.  
  530.   IF (opt% AND 2) = 0 THEN
  531.   sn% = 2
  532.   GOSUB Playsound
  533.   END IF
  534.  
  535.   IF pna = 11 AND pnb <>8 THEN
  536.     IF (opt% AND 2) = 0 THEN
  537.     SLEEP FOR .25
  538.     sn% = 3
  539.     GOSUB Playsound
  540.     END IF
  541.   END IF
  542.   
  543.   gturn  = 1
  544.  
  545.   IF pna = 12 THEN
  546.     WINDOW OUTPUT 2
  547.     PRINT : PRINT "You lose."
  548.     WINDOW OUTPUT 3
  549.     IF (opt% AND 2) = 0 THEN
  550.     sn% = 4
  551.     GOSUB Playsound
  552.     END IF
  553.     GOTO Finish
  554.   END IF
  555.  
  556.   GOSUB Swait
  557.  
  558.   gturn  = 0
  559.   
  560.   CASE
  561.   pna = 1 AND pnb = 10: board(pxa, pya) = 13 : board(pxb, pyb) = 14 : goto elabel2
  562.   pna = 11 AND pnb = 8: board(pxa, pya) = 13 : board(pxb, pyb) = 14 : goto elabel2
  563.   pna = 11 AND pnb <>8: board(pxb, pyb) = 14 : captured(pnb) = captured(pnb)+1 : goto elabel2
  564.   pna = pnb: board(pxa, pya) = 14 : board(pxb, pyb) = 14 : captured(pna) = captured(pna)+1 :  goto elabel2
  565.   pna < pnb and rule2 = 1: board(pxb, pyb) = pna : board(pxa, pya) = 14 : captured(pnb) = captured(pnb)+1 : goto elabel2
  566.   pna < pnb and rule2 <>1: board(pxb, pyb) = 14 : captured(pnb) = captured(pnb)+1 : goto elabel2
  567.   END CASE
  568.  
  569.   board(pxa, pya) = 13
  570.   board(pxb, pyb) = 14
  571.   
  572. elabel2:
  573.  
  574. ELSE
  575.  
  576.   board(pxb, pyb) = 14
  577.   board(pxa, pya) = 13
  578.  
  579. END IF
  580.  
  581. pn = board(pxa, pya)
  582. IF pn = 13 THEN
  583.   pn = 16 : opx% = pxa : opy% = pya
  584. ELSE
  585.   opx% = -1 : opy% = -1
  586. END IF 
  587. IF pn>12 THEN
  588.   bc = 2
  589. ELSE
  590.   bc = 0
  591. END IF
  592. px = pxa : py = pya : GOSUB Putpiece
  593.  
  594. pn = board(pxb, pyb)
  595. IF pn=13 THEN
  596.   bc = 2
  597. ELSE
  598.   bc = 0
  599. END IF
  600. px = pxb : py = pyb : GOSUB Putpiece
  601.  
  602. IF (opt% AND 2) = 0 THEN
  603. sn% = 1
  604. GOSUB Playsound
  605. END IF
  606.  
  607. movenum = movenum + 1
  608.  
  609. GOTO Ourturn
  610.  
  611.  
  612. ' We are finished with the game now.  Only may exit via menu.  Tacky, I know.
  613. Finish:
  614. gturn = 1
  615. gameover% = 1
  616. Finish2:
  617. GOSUB Gwait
  618. GOTO Finish2
  619.  
  620.  
  621.  
  622. Drawboard:
  623. bx1 = 0 : by1 = 0 : bx2 = 161 : by2 = 161
  624. COLOR 5, 0
  625. GOSUB Fillbox
  626.  
  627. bx1 = 3 : by1 = 3
  628. COLOR 1, 0
  629. GOSUB Fillbox
  630.  
  631. FOR py=0 TO 9
  632. FOR px=0 TO 9
  633. pn = board(px,py)
  634. IF pn=13 THEN
  635.   bc = 2
  636. ELSE
  637.   bc = 0
  638. END IF
  639. IF pn>0 THEN GOSUB Putpiece
  640. NEXT px
  641. NEXT py
  642.  
  643. COLOR 6, 0 
  644.  
  645. bx1 = 37 : by1 = 69 : bx2 = 29 : by2 = 29
  646. GOSUB Fillbox
  647.  
  648. bx1 = 101
  649. GOSUB Fillbox
  650. RETURN
  651.  
  652.  
  653. Putpiece:
  654.  
  655. ' Color the square green to write over old piece.
  656. COLOR 3, 0
  657. bx2 = 13 : by2 = 13
  658. bx1 = px*16 + 5
  659. by1 = py*16 + 5
  660. GOSUB Fillbox
  661.  
  662. ' Blank square.
  663. IF pn = 14 THEN RETURN
  664.  
  665. ' Our color is 4, there's is 2, black is 0, white is 1.
  666. IF bc<2 THEN
  667.     COLOR 4, 0
  668. ELSE
  669.     COLOR 2, 0
  670. END IF
  671.  
  672. bx2 = 9 : by2 = 9
  673. bx1 = px*16 + 7
  674. by1 = py*16 + 7
  675. GOSUB Fillbox
  676.  
  677. IF bc=0 THEN
  678.     COLOR 0, 4
  679. END IF
  680. IF bc=1 THEN
  681.     COLOR 1, 4
  682. END IF
  683. IF bc=2 THEN
  684.     COLOR 0, 2
  685. END IF
  686. IF bc=3 THEN
  687.     COLOR 1, 2
  688. END IF
  689.  
  690. LOCATE  py*2 + 2, px*2 + 2
  691. PRINT MID$(pc$, pn, 1);
  692. RETURN
  693.  
  694.  
  695. Fillbox:
  696. AREA (bx1, by1 ) : AREA STEP (bx2, 0) : AREA STEP (0, by2) : AREA STEP (-bx2, 0)
  697. AREAFILL
  698. RETURN
  699.  
  700.  
  701. Piecenum:
  702. pnb = 0
  703. FOR i = 1 TO 13
  704. IF rec$ = MID$(pc$, i, 1) THEN pnb = i
  705. NEXT i
  706. RETURN
  707.  
  708.  
  709. Loadboard:
  710. OPEN "I",2,file$
  711. IF err<>0 THEN ERMSG$="Error opening "+file$+" to load board." : GOTO Errr
  712. FOR j=0 TO 9
  713. FOR i=0 TO 9
  714. INPUT #2, board(i,j)
  715. NEXT i
  716. NEXT j
  717. INPUT #2, rturn%
  718. CLOSE #2
  719. RETURN
  720.  
  721.  
  722. Saveboard:
  723. OPEN "O",2,file$
  724. IF err<>0 THEN ERMSG$="Error opening "+file$+" to save board." : GOTO Errr
  725. FOR j=0 TO 9
  726. FOR i=0 TO 9
  727. PRINT #2, board(i,j)
  728. NEXT i
  729. NEXT j
  730. PRINT #2, rturn%
  731. CLOSE #2
  732. RETURN
  733.  
  734.  
  735. ' This is the main polling subroutine.  Handles modem, mouse, etc.
  736. Gwait:
  737.  
  738. ON MENU GOSUB Menuhandler
  739. MENU ON
  740. SLEEP
  741.  
  742. REM Process menu selection.
  743. IF m0>0 THEN
  744.   IF m0 = 3 AND m1 = 2 AND gturn = 1 AND movenum > 0 THEN RETURN  ' Concede the game.
  745.   IF m0 = 1 AND m1 = 1 AND gturn = 1 AND movenum = 0 THEN RETURN  ' Done setting up.
  746.   m0 = 0
  747.   GOTO Gwait
  748. END IF
  749.  
  750. REM Process mouse button.
  751. IF MOUSE(0) <> 0 THEN
  752.  
  753.   IF gturn = 1 AND mstat%=1 THEN
  754.     GOTO Gwait
  755.   END IF
  756.  
  757.   IF gturn = 1 AND mstat%=0 THEN
  758.     mstat% = 1
  759.     px = MOUSE(1) : py = MOUSE(2)
  760.     px = INT((px-5)/16) : py = INT((py-4)/16)
  761.  
  762.     IF px<0 OR px>9 OR py<0 OR py>9 OR board(px,py)<1 THEN GOTO Abortmouse
  763.  
  764.     RETURN
  765.  
  766.     Abortmouse: 
  767.  
  768.   END IF
  769.  
  770. ELSE
  771.   mstat% = 0
  772. END IF
  773.  
  774. REM Process keyboard
  775. bb$ = INKEY$
  776. IF bb$<> "" THEN
  777.   b$ = bb$
  778.   GOSUB Entermess
  779. END IF
  780.  
  781. MENU OFF
  782.  
  783. REM Process Modem.
  784. Procmodem:
  785. GOSUB Getmodem
  786.  
  787. IF b$ <> "" THEN
  788.  
  789.   WINDOW OUTPUT 1
  790.   PRINT b$;
  791.   WINDOW OUTPUT 3
  792.  
  793.   IF b$ <> MID$(delim$, ((ourcolor+1) MOD 2)+1, 1) THEN GOTO Procmodem
  794.  
  795.   packet$ = ""
  796.  
  797.   timeflag% = 0
  798.   vtflag% = 0
  799.  
  800.   Hwait:
  801.   GOSUB Getmodem
  802.  
  803.   IF b$<> "" THEN
  804.  
  805.     WINDOW OUTPUT 1
  806.     PRINT b$;
  807.     WINDOW OUTPUT 3
  808.  
  809. ' The following code was added to filter out VT-100 escape sequences which are used with talk.
  810. ' These sequences start with "(ESC)[" and end with "H", "K", "J", or "r".
  811.     IF ASC(b$) = 27 THEN
  812.       vtflag% = 1
  813.       GOTO Hwait
  814.     END IF
  815.     IF vtflag%=1 AND b$="[" THEN
  816.       vtflag% = 2
  817.       vtcount% = 0
  818.       GOTO Hwait
  819.     END IF
  820.     IF vtflag%=2 THEN
  821.       vtcount% = vtcount%+1
  822.       IF vtcount%>10 THEN vtflag% = 0
  823.       FOR chkvt%=1 TO LEN(vtcode$)
  824.         IF b$=MID$(vtcode$,chkvt%,1) THEN
  825.           vtflag% = 0
  826.         END IF
  827.       NEXT chkvt%
  828.       GOTO Hwait
  829.     END IF
  830.  
  831.  
  832.     IF b$ = MID$(delim$, ((ourcolor+1) MOD 2)+3, 1) THEN GOTO Checkit
  833.  
  834.     IF ASC(b$) < first%+((ourcolor+1) MOD 2)*32 OR ASC(b$) > first%+((ourcolor+1) MOD 2)*32+31 THEN GOTO Hwait
  835.  
  836.     packet$ = packet$+b$
  837.     GOTO Hwait
  838.   END IF
  839.     
  840.   SLEEP
  841.  
  842.   ++timeflag%
  843.  
  844.   IF timeflag% < 8 THEN GOTO Hwait
  845.  
  846. REM Timeout error.
  847.   send$ = "R"+STR$(thermess%)
  848.   GOSUB Sendit
  849.   thermess%  = thermess%+1
  850.   WINDOW OUTPUT 2
  851.   PRINT
  852.   PRINT "Data Timeout"
  853.   WINDOW OUTPUT 3
  854.   GOTO Gwait
  855.   
  856.   Checkit:
  857.   GOSUB Decode
  858.  
  859. REM Checksum error.
  860.   IF rec$ = "ER" THEN 
  861.     send$ = "R"+STR$(thermess%)
  862.     GOSUB Sendit
  863.     thermess%  = thermess%+1
  864.     WINDOW OUTPUT 2
  865.     PRINT
  866.     PRINT "Chksum Err"
  867.     WINDOW OUTPUT 3
  868.     GOTO Gwait
  869.   END IF
  870.  
  871. REM Message from opponent.  
  872.   IF LEFT$(rec$,1)="Z" THEN
  873.     rec$ = RIGHT$(rec$, LEN(rec$)-1)
  874.     WINDOW OUTPUT 2
  875.     PRINT 
  876.     PRINT "Opponent:"
  877.  
  878. ' Bug when printing CR's in strings.
  879.  
  880.     FOR i=1 to len(rec$)
  881.       IF mid$(rec$, i, 1)=chr$(13) THEN
  882.         PRINT
  883.       ELSE
  884.         PRINT mid$(rec$, i, 1);
  885.       END IF
  886.     NEXT i
  887.     PRINT
  888.  
  889.     tell$ = rec$
  890.     GOSUB Sayit
  891.     thermess%  = thermess%+1
  892.     WINDOW OUTPUT 3
  893.     GOTO Gwait
  894.   END IF
  895.  
  896. REM Ping/Pong received.
  897.   IF LEFT$(rec$,1)="P" THEN
  898.     IF rec$="PING" THEN
  899.       WINDOW OUTPUT 2
  900.       PRINT 
  901.       PRINT "Ping!"
  902.       send$ = "PONG" 
  903.       GOSUB Sendit
  904.     END IF
  905.  
  906.     IF rec$="PONG" THEN
  907.       WINDOW OUTPUT 2
  908.       PRINT 
  909.       PRINT "Pong!"
  910.     END IF
  911.     thermess%  = thermess%+1
  912.     WINDOW OUTPUT 3
  913.     GOTO Gwait
  914.   END IF
  915.  
  916. REM Sanity Check received.
  917.   IF LEFT$(rec$, 2)="S1" THEN
  918.     WINDOW OUTPUT 2
  919.     send$="S2"+chr$((ourmess% MOD 10)+2)
  920.     
  921.     IF (ASC(MID$(rec$, 3, 1))-2) <> (thermess% MOD 10) THEN
  922.       thermess% = ASC(MID$(rec$, 3, 1))-2
  923.       PRINT
  924.       PRINT "Sync Error"
  925.       PRINT "Opponent"
  926.       send$ = send$+chr$(2)
  927.     ELSE
  928.       send$ = send$+chr$(3)
  929.     END IF
  930.  
  931.     sanchk% = 0
  932.  
  933.     FOR stobodx% = 9 TO 0 STEP -1
  934.     FOR stobody% = 9 TO 0 STEP -1
  935.  
  936.       bochk% = ASC(MID$(rec$, 4+(9-stobody%)+(9-stobodx%)*10, 1))
  937.  
  938.       IF bochk% = 3 THEN
  939.         IF board(stobodx%, stobody%)>0 AND board(stobodx%, stobody%)<14 THEN
  940.           sanchk% = 1
  941.         END IF
  942.       END IF
  943.  
  944.       IF bochk% = 2 THEN
  945.         IF board(stobodx%, stobody%)<1 OR board(stobodx%, stobody%)>12 THEN
  946.           sanchk% = 1
  947.         END IF
  948.       END IF
  949.  
  950.       IF bochk% = 4 THEN
  951.         IF board(stobodx%, stobody%)<>13 THEN
  952.           sanchk% = 1
  953.         END IF
  954.       END IF
  955.  
  956.     NEXT stobody%
  957.     NEXT stobodx%
  958.  
  959.     IF sanchk% = 0 THEN
  960.       send$ = send$+chr$(3)
  961.     ELSE
  962.       PRINT
  963.       PRINT "FATAL:"
  964.       PRINT "Sanity Error"
  965.       send$ = send$+chr$(2)
  966.     END IF
  967.  
  968.     GOSUB Sendit
  969.     thermess%  = thermess%+1
  970.     WINDOW OUTPUT 3
  971.     GOTO Gwait
  972.   END IF
  973.  
  974.   
  975. REM Opponent has sent his pieces..
  976.   IF LEFT$(rec$, 1)="X" THEN
  977.     WINDOW OUTPUT 2
  978.     PRINT : PRINT "Getting board."
  979.     WINDOW OUTPUT 3
  980.     FOR stobodx% = 0 TO 9
  981.     FOR stobody% = 0 TO 9
  982.       bochk% = ASC(MID$(rec$, 2+(9-stobody%)+(9-stobodx%)*10, 1))-1
  983.       IF bochk%>0 AND bochk%<13 THEN
  984.       pn = bochk% : px = stobodx% : py = stobody% : bc = 2 : GOSUB Putpiece
  985.       END IF
  986.     NEXT stobody%
  987.     NEXT stobodx%
  988.     thermess%  = thermess%+1
  989.     GOTO Gwait
  990.   END IF
  991.  
  992.  
  993.   IF LEFT$(rec$, 2)="S2" THEN
  994.     WINDOW OUTPUT 2
  995.     PRINT
  996.     PRINT "Sanity checked."
  997.     IF (ASC(MID$(rec$, 3, 1))-2) <> (thermess% MOD 10) THEN
  998.       thermess% = ASC(MID$(rec$, 3, 1))-2
  999.       PRINT
  1000.       PRINT "Sync Error"
  1001.       PRINT "Opponent"
  1002.     END IF
  1003.  
  1004.     IF ASC(MID$(rec$, 4, 1))=2 THEN
  1005.       PRINT
  1006.       PRINT "Sync Error"
  1007.       PRINT "Our Side"
  1008.     END IF
  1009.  
  1010.     IF ASC(MID$(rec$, 5, 1))=2 THEN
  1011.       PRINT
  1012.       PRINT "FATAL:"
  1013.       PRINT "Sanity Error"
  1014.     END IF
  1015.  
  1016.     thermess%  = thermess%+1
  1017.     WINDOW OUTPUT 3
  1018.     GOTO Gwait
  1019.   END IF
  1020.  
  1021.  
  1022. REM Rule change.  
  1023.   IF LEFT$(rec$,1)="Y" THEN
  1024.     
  1025.     rec$ = RIGHT$(rec$, LEN(rec$)-2)
  1026.     rulech% = VAL(rec$)
  1027.  
  1028.     CASE  
  1029.     rulech% = 0: rule1 = 0 : MENU 3, 3, 1, "  Scout Strike"
  1030.     rulech% = 1: rule1 = 1 : MENU 3, 3, 1, "* Scout Strike"
  1031.     rulech% = 2: rule2 = 0 : MENU 3, 4, 1, "  Defender Occupies"
  1032.     rulech% = 3: rule2 = 1 : MENU 3, 4, 1, "* Defender Occupies"
  1033.     END CASE
  1034.  
  1035.     WINDOW OUTPUT 2
  1036.     PRINT 
  1037.     PRINT "Rule Change."
  1038.     WINDOW OUTPUT 3
  1039.        
  1040.     thermess%  = thermess%+1
  1041.     GOTO Gwait
  1042.  
  1043.   END IF
  1044.  
  1045. REM Resend.  
  1046.   IF LEFT$(rec$,1)="R" THEN
  1047.     rec$ = RIGHT$(rec$, LEN(rec$)-2)
  1048.     rsnum% = VAL(rec$)
  1049.     send$ = messbuf$(rsnum% MOD 30)
  1050.     GOSUB Sendit
  1051.  
  1052.     thermess%  = thermess%+1
  1053.  
  1054.     WINDOW OUTPUT 2
  1055.     PRINT 
  1056.     PRINT "Resend."
  1057.     WINDOW OUTPUT 3
  1058.     GOTO Gwait
  1059.     
  1060.   END IF
  1061.  
  1062. REM Opponent is done setting up.
  1063.   IF rec$ = "OK" THEN
  1064.     opready% = 1
  1065.     WINDOW OUTPUT 2
  1066.     PRINT 
  1067.     PRINT "Opponent"
  1068.     PRINT "Ready."
  1069.     WINDOW OUTPUT 3
  1070.     thermess%  = thermess%+1
  1071.     IF gturn = 0 THEN RETURN
  1072.     GOTO Gwait
  1073.   END IF
  1074.   
  1075.   IF gturn = 1 THEN
  1076.       WINDOW OUTPUT 2
  1077.       PRINT "FATAL:
  1078.       PRINT "Error #2"
  1079.       WINDOW OUTPUT 3
  1080.   END IF
  1081.  
  1082.   thermess%  = thermess%+1
  1083.  
  1084.   RETURN
  1085.         
  1086. END IF
  1087.  
  1088. GOTO Gwait:
  1089.  
  1090.  
  1091. ' This subroutine lets you enter a message to send to the opponent.
  1092. Entermess:
  1093.   WINDOW OUTPUT 2
  1094.   ActivateWindow(window(7))
  1095.  
  1096.   PRINT 
  1097.   PRINT "Type Message:"
  1098.   sendmes$ = chr$(0)
  1099.   stormes$ = chr$(0)
  1100.  
  1101.   totlen% = 0
  1102.   lspc% = 0
  1103.   colm% = 1
  1104.  
  1105.   IF b$<>"" THEN GOTO Gotoneb4
  1106.   
  1107.   Gettext2:
  1108.   IF (opt% AND 1) = 0 THEN SLEEP
  1109.   b$ = INKEY$
  1110.  
  1111.   IF b$ = "" THEN GOTO Gettext2
  1112.  
  1113.   Gotoneb4:
  1114.  
  1115.   IF (b$ = CHR$(127) OR b$ = CHR$(8)) THEN
  1116.     IF colm%>1 THEN
  1117.       totlen% = totlen%-1
  1118.       colm% = colm% - 1
  1119.       PRINT CHR$(8);
  1120.       sendmes$ = LEFT$(sendmes$, LEN(sendmes$)-1)
  1121.       stormes$ = LEFT$(stormes$, LEN(stormes$)-1)
  1122.       lspc% = 0
  1123.  
  1124.       IF colm%>1 THEN
  1125.         FOR er% = colm%-1 TO 1 STEP -1
  1126.           IF MID$(sendmes$, LEN(sendmes$)-colm%+er%+1, 1) = " " THEN
  1127.             lspc% = er%
  1128.             er% = 1
  1129.           END IF
  1130.         NEXT er%
  1131.       END IF
  1132.  
  1133.     END IF
  1134.  
  1135.     GOTO Gettext2
  1136.  
  1137.   END IF
  1138.  
  1139.   IF totlen% = 79 and b$<>CHR$(13) THEN GOTO Gettext2
  1140.  
  1141.   totlen% = totlen%+1
  1142.  
  1143.   IF colm% = 16 THEN
  1144.     IF lspc% = 0 THEN
  1145.       colm% = 0
  1146.       sendmes$ = sendmes$+b$+chr$(13)  
  1147.       stormes$ = stormes$+b$
  1148.       PRINT b$
  1149.     ELSE
  1150.       FOR er% = 1 to 15-lspc%
  1151.         PRINT chr$(8);
  1152.       NEXT er%
  1153.       PRINT
  1154.       PRINT right$(sendmes$,15-lspc%);b$;
  1155.       sendmes$ = left$(sendmes$, len(sendmes$)-(15-lspc%))+chr$(13)+right$(sendmes$,15-lspc%)+b$
  1156.       stormes$ = stormes$+b$
  1157.       colm% = 16-lspc%
  1158.       lpsc% = 0
  1159.     END IF
  1160.   ELSE
  1161.     sendmes$ = sendmes$+b$
  1162.     stormes$ = stormes$+b$
  1163.     PRINT b$;
  1164.   END IF
  1165.  
  1166.   IF b$=" " THEN
  1167.      lspc% = colm%
  1168.   END IF
  1169.  
  1170.   colm% = colm%+1
  1171.  
  1172.   IF b$ = CHR$(13) THEN GOTO Gettext3
  1173.   GOTO Gettext2
  1174.  
  1175.   Gettext3:
  1176.  
  1177.   sendmes$ = left$(sendmes$, len(sendmes$)-1)
  1178.   stormes$ = left$(stormes$, len(stormes$)-1)
  1179.  
  1180.   PRINT
  1181.  
  1182.   send$ = "Z"+sendmes$
  1183.   GOSUB Sendit
  1184.  
  1185.   tell$ = sendmes$
  1186.   GOSUB Sayit          
  1187.  
  1188.   WINDOW OUTPUT 3
  1189.   ActivateWindow(window(7))
  1190.  
  1191.   IF recmode%=1 AND sendmes$<>chr$(13) THEN
  1192.     message$(messmenu - 4) = sendmes$
  1193.     mmessage$(messmenu - 4) = left$(stormes$, 26) 
  1194.     MENU 2, messmenu, 1, mmessage$(messmenu-4)
  1195.     messmenu = messmenu + 1
  1196.     IF messmenu = 19 THEN messmenu = 5
  1197.   END IF
  1198.  
  1199. RETURN
  1200.  
  1201.  
  1202. Swait:
  1203. IF  MOUSE(0) < 0 THEN mstat%=1 : RETURN
  1204. SLEEP
  1205. GOTO Swait
  1206.  
  1207.  
  1208. Initmenu:
  1209. MENU 1, 0, 1, "Setup"
  1210. MENU 1, 1, 1, "Done  Setting Up"
  1211. MENU 1, 2, 1, "----------------"
  1212. MENU 1, 3, 1, "Load Setup #1"
  1213. MENU 1, 4, 1, "Load Setup #2"
  1214. MENU 1, 5, 1, "Load Setup #3"
  1215. MENU 1, 6, 1, "Load Setup #4"
  1216. MENU 1, 7, 1, "Load Setup #5"
  1217. MENU 1, 8, 1, "----------------"
  1218. MENU 1, 9, 1, "Save Setup #1"
  1219. MENU 1, 10, 1, "Save Setup #2"
  1220. MENU 1, 11, 1, "Save Setup #3"
  1221. MENU 1, 12, 1, "Save Setup #4"
  1222. MENU 1, 13, 1, "Save Setup #5"
  1223.  
  1224. MENU 2, 0, 1, "Dialog"
  1225. MENU 2, 1, 1, "Send A Message"
  1226. IF recmode%=1 then MENU 2, 2, 1, "Message Buffer Is On"
  1227. IF recmode%=0 then MENU 2, 2, 1, "Message Buffer Is Off"
  1228. MENU 2, 3, 1, "Send Ping"
  1229. MENU 2, 4, 1, "--------------------------"
  1230.  
  1231. FOR mendex%=5 to 18
  1232.   IF mmessage$(mendex%-4)<>chr$(0) THEN
  1233.     MENU 2, mendex%, 1, mmessage$(mendex%-4)
  1234.   ELSE
  1235.     mendex%=18
  1236.   END IF
  1237. NEXT mendex%
  1238.  
  1239. MENU 3, 0, 1, "Game"
  1240. MENU 3, 1, 1, "  Rank Report"
  1241. MENU 3, 2, 1, "  Concede Game"
  1242. IF rule1 = 0 THEN MENU 3, 3, 1, "  Scout Strike"
  1243. IF rule1 = 1 THEN MENU 3, 3, 1, "* Scout Strike"
  1244. IF rule2 = 0 THEN MENU 3, 4, 1, "  Defender Occupies"
  1245. IF rule2 = 1 THEN MENU 3, 4, 1, "* Defender Occupies"
  1246. MENU 3, 5, 1, "  Sanity Check"
  1247. MENU 3, 6, 1, "  Reveal Pieces"
  1248. MENU 3, 7, 1, "  Restart as Red"
  1249. MENU 3, 8, 1, "  Restart as Blue"
  1250. MENU 3, 9, 1, "  Exit to Terminal"
  1251. MENU 3, 10, 1, "  Exit Program"
  1252.  
  1253. RETURN
  1254.  
  1255.  
  1256. Inittermmenu:
  1257. MENU 1, 0, 1, "Setup"
  1258. MENU 1, 1, 1, "Setup Game as Red"
  1259. MENU 1, 2, 1, "Setup Game as Blue"
  1260. MENU 1, 3, 1, "Hangup Modem"
  1261. MENU 1, 4, 1, "Exit Program"
  1262.  
  1263. MENU 2, 0, 1, "Macros"
  1264. FOR mac%=1 TO 10
  1265. MENU 2, mac%, 1, LEFT$(macro$(mac%),20)
  1266. NEXT mac%
  1267. RETURN
  1268.  
  1269.  
  1270. Menuhandler:
  1271.  
  1272. m0 = MENU(0) : m1 = MENU(1)
  1273.  
  1274. IF m0 = 1 THEN
  1275.   IF m1>2 AND m1<8 THEN
  1276.     IF lockboard% = 0 THEN
  1277.       file$ = "setup"+CHR$(48+m1-2)+".data"
  1278.       GOSUB Loadboard
  1279.       GOSUB Drawboard
  1280.     ELSE
  1281.       IF lockboard% = 1 THEN
  1282.         WINDOW OUTPUT 2
  1283.         PRINT
  1284.         PRINT "Unselect"
  1285.         PRINT "piece first."
  1286.       ELSE
  1287.         WINDOW OUTPUT 2
  1288.         PRINT
  1289.         PRINT "You may not"
  1290.         PRINT "load a board"
  1291.         PRINT "now, you are"
  1292.         PRINT "playing!"
  1293.       END IF
  1294.     END IF
  1295.   END IF
  1296.   IF m1>8 AND m1<14 THEN
  1297.     file$ = "setup"+CHR$(48+m1-8)+".data"
  1298.     GOSUB Saveboard
  1299.   END IF
  1300. END IF
  1301.  
  1302. IF m0 = 2 THEN
  1303.  
  1304.   IF m1 = 1 THEN
  1305.     GOSUB Entermess
  1306.   END IF
  1307.  
  1308.   IF m1 = 2 THEN
  1309.      IF recmode% = 0 THEN
  1310.         recmode%  = 1
  1311.         MENU 2, 2, 1, "Message Buffer Is On"
  1312.      ELSE
  1313.         recmode%  = 0
  1314.         MENU 2, 2, 1, "Message Buffer Is Off"
  1315.      END IF
  1316.   END IF
  1317.  
  1318.   IF m1 = 3 THEN
  1319.     send$ = "PING" 
  1320.     GOSUB Sendit
  1321.     WINDOW OUTPUT 2
  1322.     PRINT
  1323.     PRINT "Ping..."
  1324.   END IF
  1325.  
  1326.   IF m1 > 4 THEN
  1327.     send$ = "Z"+message$(m1-4) 
  1328.     GOSUB Sendit
  1329.     WINDOW OUTPUT 2
  1330.     PRINT
  1331.     PRINT "To Opponent:"
  1332.  
  1333. ' Strange when printing CR's in strings.
  1334.  
  1335.     FOR er%=1 to len(message$(m1-4))
  1336.       IF mid$(message$(m1-4), er%, 1) = chr$(13) THEN
  1337.         PRINT
  1338.       ELSE
  1339.         PRINT mid$(message$(m1-4), er%, 1);
  1340.       END IF
  1341.     NEXT er%
  1342.     PRINT
  1343.  
  1344.     tell$ = message$(m1-4)
  1345.     GOSUB Sayit
  1346.   END IF
  1347.  
  1348. END IF
  1349.  
  1350. IF m0 = 3 THEN
  1351.  
  1352.   IF m1 = 1 THEN
  1353.     WINDOW OUTPUT 2
  1354.     PRINT : PRINT "Pieces Captured:"
  1355.     FOR k = 1 TO 12 : PRINT MID$(pc$, k, 1);"  / ";captured(k) : NEXT k
  1356.   END IF
  1357.  
  1358.   IF m1 = 3 AND ourcolor = 0 AND movenum = 0 THEN
  1359.     IF rule1 = 0 THEN
  1360.       rule1 = 1
  1361.       MENU 3, 3, 1, "* Scout Strike"
  1362.       rulech% = 1
  1363.      ELSE
  1364.       rule1 = 0
  1365.       MENU 3, 3, 1, "  Scout Strike"
  1366.       rulech% = 0
  1367.     END IF
  1368.     send$ = "Y"+STR$(rulech%)
  1369.     GOSUB Sendit
  1370.   END IF
  1371.  
  1372.   IF m1 = 4 AND ourcolor = 0 AND movenum = 0 THEN
  1373.  
  1374.     IF rule2 = 0 THEN
  1375.       rule2 = 1
  1376.       MENU 3, 4, 1, "* Defender Occupies"
  1377.       rulech% = 3
  1378.     ELSE
  1379.       rule2  = 0
  1380.       MENU 3, 4, 1, "  Defender Occupies"
  1381.       rulech% = 2
  1382.     END IF
  1383.     send$ = "Y"+STR$(rulech%)
  1384.     GOSUB Sendit
  1385.   END IF
  1386.  
  1387.   IF m1 = 5 THEN
  1388.   IF gturn = 0 THEN
  1389.     WINDOW OUTPUT 2
  1390.     PRINT : PRINT "Not your turn."
  1391.     WINDOW OUTPUT 3
  1392.   ELSE
  1393.     GOSUB Sancheck
  1394.   END IF
  1395.   END IF
  1396.  
  1397.   IF m1 = 6 THEN
  1398.   IF gameover%=0 THEN
  1399.     WINDOW OUTPUT 2
  1400.     PRINT : PRINT "Game not over."
  1401.   ELSE
  1402.     WINDOW OUTPUT 2
  1403.     PRINT : PRINT "Sending board."
  1404.     send$ = "X"
  1405.     FOR stobodx% = 0 TO 9
  1406.     FOR stobody% = 0 TO 9
  1407.       IF board(stobodx%, stobody%)>0 AND board(stobodx%, stobody%)<13 THEN
  1408.           send$ = send$+CHR$(1+board(stobodx%, stobody%))
  1409.         ELSE
  1410.           send$ = send$+CHR$(16)
  1411.       END IF
  1412.     NEXT stobody%
  1413.     NEXT stobodx%
  1414.     GOSUB Sendit
  1415.   END IF
  1416.   END IF
  1417.  
  1418.   IF m1 = 7 THEN
  1419.   IF gameover%=0 THEN
  1420.     WINDOW OUTPUT 2
  1421.     PRINT : PRINT "Game not over."
  1422.   ELSE
  1423.     ourcolor=0
  1424.     GOTO Newgame
  1425.   END IF
  1426.   END IF
  1427.  
  1428.   IF m1 = 8 THEN
  1429.   IF gameover%=0 THEN
  1430.     WINDOW OUTPUT 2
  1431.     PRINT : PRINT "Game not over."
  1432.   ELSE
  1433.     ourcolor=1
  1434.     GOTO Newgame
  1435.   END IF
  1436.   END IF
  1437.  
  1438.   IF m1 = 9 THEN
  1439.     GOTO Restart
  1440.   END IF
  1441.  
  1442.   IF m1 = 10 THEN
  1443.     GOSUB Closeall
  1444.     STOP
  1445.   END IF
  1446.  
  1447. END IF
  1448.  
  1449. WINDOW OUTPUT 3
  1450. ActivateWindow(window(7))
  1451.  
  1452. RETURN
  1453.  
  1454. Sancheck:
  1455. WINDOW OUTPUT 2
  1456. PRINT
  1457. PRINT "Checking the"
  1458. PRINT "boards..."
  1459. WINDOW OUTPUT 3
  1460. send$ = "S1"+chr$((ourmess% MOD 10)+2)
  1461. FOR stobodx% = 0 TO 9
  1462. FOR stobody% = 0 TO 9
  1463.   IF board(stobodx%, stobody%)>0 AND board(stobodx%, stobody%)<14 THEN
  1464.     IF board(stobodx%, stobody%) = 13 THEN
  1465.       send$ = send$+CHR$(2)
  1466.     ELSE
  1467.       send$ = send$+CHR$(4)
  1468.     END IF
  1469.   ELSE
  1470.     send$ = send$+CHR$(3)
  1471.   END IF
  1472. NEXT stobody%
  1473. NEXT stobodx%
  1474. GOSUB Sendit
  1475. RETURN
  1476.  
  1477. Termmenuhandler:
  1478. m0 = MENU(0) : m1 = MENU(1)
  1479. RETURN
  1480.  
  1481. Getmodem:
  1482. b$ = ""
  1483. chars% = serial(1,0)
  1484. IF chars%<>0 THEN serial read 1, b$, 1
  1485. RETURN
  1486.  
  1487.  
  1488. Sayit:
  1489. REM SAY TRANSLATE$(tell$),voice%
  1490. PRINT #3, tell$+chr$(13)
  1491. RETURN
  1492.  
  1493.  
  1494. Closeall:
  1495. MENU CLEAR
  1496. IF screenstat%>0 THEN
  1497.   WINDOW CLOSE 3
  1498.   WINDOW CLOSE 2
  1499.   SCREEN CLOSE 2
  1500. END IF
  1501.  
  1502. IF screenstat%>-1 THEN
  1503.   WINDOW CLOSE 1
  1504.   SCREEN CLOSE 1
  1505. END IF
  1506.  
  1507. IF screenstat%>-2 THEN
  1508.   SERIAL CLOSE 1
  1509. END IF
  1510.  
  1511. IF screenstat%>-3 THEN
  1512.   CLOSE 3
  1513. END IF
  1514. RETURN
  1515.  
  1516.  
  1517. Errr:
  1518. GOSUB Closeall
  1519. PRINT
  1520. PRINT ERMSG$
  1521. PRINT
  1522. STOP
  1523.  
  1524.  
  1525.  
  1526. '
  1527. ' These are the packet encoding and decoding routines.
  1528. '
  1529.  
  1530. Sendit:
  1531.  
  1532. messbuf$(ourmess% MOD 30) = send$
  1533.  
  1534. ' Put string into integer array for checksum and packing.
  1535. pack%(1) = 0 : pack%(2) = 0
  1536. FOR cheki%=1 TO LEN(send$) : pack%(cheki%+2) = ASC(MID$(send$, cheki%, 1)) : NEXT cheki%
  1537. packlen% = LEN(send$)+2
  1538.  
  1539. ' Pad message to even 5 bytes.
  1540. IF packlen% MOD 5 <> 0 THEN
  1541.   FOR cheki%=1 TO 5-(packlen% MOD 5)
  1542.     pack%(cheki%+packlen%) = 0
  1543.   NEXT cheki%
  1544.   packlen% = packlen%+5-(packlen% MOD 5)
  1545. END IF
  1546.  
  1547. ' Prepend CRC16 checksum
  1548. GOSUB Crc16calc
  1549. pack%(1) = check& AND 255 : pack%(2) = SHR(check&,8)
  1550.  
  1551. ' Commented code simulates data errors for testing.
  1552. 'IF RND(0)<.2 THEN pack%(1) = pack%(1)+1
  1553.  
  1554. nmblk%  = packlen%/5
  1555. trans$  = MID$(delim$, ourcolor+1, 1)
  1556. bas%  = first%+ourcolor*32
  1557.  
  1558. ' We pack bytes into 5 bit ASCII characters from 63-126 (each player uses 32
  1559. ' of the 64 available characters).
  1560. FOR curblk% = 0 TO nmblk%-1
  1561.   trans$  = trans$ + CHR$(bas%+SHR(pack%((curblk%*5)+1),3))
  1562.   trans$  = trans$ + CHR$(bas%+SHL((pack%((curblk%*5)+1) AND 7),2) + SHR(pack%((curblk%*5)+2),6))
  1563.   trans$  = trans$ + CHR$(bas%+(SHR(pack%((curblk%*5)+2),1) AND 31))
  1564.   trans$  = trans$ + CHR$(bas%+SHL((pack%((curblk%*5)+2) AND 1),4) + SHR(pack%((curblk%*5)+3),4))
  1565.   trans$  = trans$ + CHR$(bas%+SHL((pack%((curblk%*5)+3) AND 15),1) + SHR(pack%((curblk%*5)+4),7))
  1566.   trans$  = trans$ + CHR$(bas%+(SHR(pack%((curblk%*5)+4),2) AND 31))
  1567.   trans$  = trans$ + CHR$(bas%+SHL((pack%((curblk%*5)+4) AND 3),3) + SHR(pack%((curblk%*5)+5),5))
  1568.   trans$  = trans$ + CHR$(bas%+(pack%((curblk%*5)+5) AND 31))
  1569. NEXT curblk%
  1570.  
  1571. trans$  = trans$ + MID$(delim$, ourcolor+3, 1)+chr$(13)
  1572.  
  1573. ' Commented code simulates timeout errors.
  1574. 'IF RND(0)>.2 THEN
  1575.  
  1576. serial write 1, trans$, len(trans$)
  1577.  
  1578. 'ELSE
  1579. 'serial write 1, left$(trans$, 3), 3
  1580. 'END IF
  1581.  
  1582. ourmess% = ourmess%+1
  1583. RETURN
  1584.  
  1585.  
  1586. Decode:
  1587.  
  1588. nmblk%  = LEN(packet$)/8
  1589. bas%  = first%+((ourcolor+1) MOD 2)*32
  1590.  
  1591. FOR curblk% = 0 TO nmblk%-1
  1592.   FOR iz% = 1 TO 8 : upack%(iz%) = ASC(MID$(packet$, curblk%*8+iz%, 1)) - bas% : NEXT iz%
  1593.   pack%((curblk%*5)+1) = SHL(upack%(1),3)+SHR(upack%(2),2)
  1594.   pack%((curblk%*5)+2) = (SHL(upack%(2),6)+SHL(upack%(3),1) AND 254)+SHR(upack%(4),4)
  1595.   pack%((curblk%*5)+3) = (SHL(upack%(4),4)+SHR(upack%(5),1)) AND 255
  1596.   pack%((curblk%*5)+4) = (SHL(upack%(5),7)+SHL(upack%(6),2) AND 252)+SHR(upack%(7),3)
  1597.   pack%((curblk%*5)+5) = (SHL(upack%(7),5)+upack%(8)) AND 255
  1598. NEXT curblk%
  1599.  
  1600. packlen% = nmblk%*5
  1601. GOSUB Crc16calc
  1602.  
  1603. IF check& = 0 THEN
  1604.   rec$  = ""
  1605.   FOR iz% = 3 TO nmblk%*5
  1606.     IF pack%(iz%)<>0 THEN rec$ = rec$+chr$(pack%(iz%))
  1607.   NEXT iz%
  1608. ELSE
  1609.   rec$ = "ER"
  1610. END IF
  1611.  
  1612. RETURN
  1613.  
  1614.  
  1615. Crc16calc:
  1616. ' Calculate CRC16 checksum for the array pack, starting with element
  1617. ' packlen% and ending with element 1.
  1618.  
  1619. CONST poly = &H00018005
  1620.  
  1621. check& = SHL(pack%(packlen%),8) + pack%(packlen%-1)
  1622.  
  1623. FOR ci% = packlen%-2 TO 1 STEP -1
  1624.   FOR cj%=7 TO 0 STEP -1
  1625.  
  1626.     dmask% = SHL(1,cj%)
  1627.  
  1628.     IF (pack%(ci%) AND dmask%) <> 0 THEN
  1629.       check& = SHL(check&,1) + 1
  1630.     ELSE
  1631.       check& = SHL(check&,1)
  1632.     END IF
  1633.  
  1634.     IF (check& AND &H00010000) <> 0 THEN
  1635.       check& = (check& XOR poly)
  1636.     END IF
  1637.  
  1638.   NEXT cj%
  1639. NEXT ci%
  1640.  
  1641. RETURN
  1642.  
  1643.  
  1644.  
  1645. { 
  1646.   << play a sound file! >>
  1647.   Currently handles IFF 8SVX format.
  1648.   Author: David J Benn
  1649.   Changed by Dan Oberlin
  1650. }
  1651.  
  1652.  
  1653. Readiffsounds:
  1654.  
  1655. for i=1 to numsound%
  1656.  
  1657. '..file sample_size?
  1658. open "I",1,soundfile$(i)
  1659.  
  1660. sample_size&=lof(1)
  1661.  
  1662. if sample_size&=0 then
  1663.   ERMSG$="Can't open "+soundfile$(i)+"." : GOTO Errr
  1664. end if
  1665.  
  1666.  { if IFF 8SVX sample, return
  1667.    offset from start of file to
  1668.    sample data and sampling rate in
  1669.    samples per second. }
  1670.  
  1671. '..skip FORM#### ?
  1672. dummy$=input$(8,#1)
  1673.  
  1674. '..8SVX ?
  1675. x$=input$(4,#1)
  1676. if x$="8SVX" then
  1677.  
  1678.   '..skip VHDR###
  1679.   dummy$=input$(8,#1)
  1680.  
  1681.   '..skip ULONGs x 3 
  1682.   dummy$=input$(12,#1)
  1683.  
  1684.   '..get sampling rate bytes
  1685.   hi%=asc(input$(1,#1))  '..high byte
  1686.   lo%=asc(input$(1,#1))  '..low byte
  1687.   samples_per_second&(i)=hi%*256 + lo%
  1688.  
  1689.   '..find BODY
  1690.  
  1691.   '..skip rest of Voice8Header structure
  1692.   dummy$=input$(6,#1)
  1693.  
  1694.   offset&=40  '..bytes up to this point
  1695.   repeat 
  1696.    repeat
  1697.      x$=input$(1,#1)
  1698.      offset&=offset&+1
  1699.    until x$="B" and not eof(1)
  1700.    if not eof(1) then
  1701.      body$=input$(3,#1)
  1702.      offset&=offset&+3
  1703.    end if
  1704.   until body$="ODY" and not eof(1) 
  1705.  
  1706.   if not eof(1) then
  1707.     x$=input$(4,#1)  '..skip ####   
  1708.     offset&=offset&+4
  1709.   else
  1710. ' Error in file format.
  1711.     ERMSG$="Error in soundfile "+soundfile$(i)+"." : GOTO Errr
  1712.   end if
  1713. else
  1714.   close 1
  1715. ' Error in file.
  1716.   ERMSG$="Error in soundfile "+soundfile$(i)+"." : GOTO Errr
  1717. end if
  1718.  
  1719. sz&(i)=sample_size&-offset&
  1720.  
  1721. '..get the sample bytes
  1722. buffer&(i)=Alloc(sz&(i),CHIP) '...sample_size& bytes of CHIP RAM
  1723. if buffer&(i) = NULL then 
  1724. ' Not enough chipmem.
  1725.   ERMSG$="Not enough chip RAM for sounds." : GOTO Errr
  1726. end if
  1727.  
  1728. fh& = handle(1)
  1729. bytes& = xRead(fh&,buffer&(i),sz&(i))
  1730. close 1
  1731.  
  1732. next i
  1733.  
  1734. return
  1735.  
  1736.  
  1737. Playsound:
  1738.  
  1739. '..calculate period
  1740. per& = 3579546 \ samples_per_second&(sn%)
  1741.  
  1742. if sz&(sn%) <= maxsample then
  1743.   bytes&=sz&(sn%)
  1744.   '..play it in one go
  1745.   wave channel,buffer&(sn%),sz&(sn%)
  1746.   dur&=.279365*per&*bytes&/1e6*18.2
  1747.   if dur&>1 then dur& = dur&-1
  1748.   sound per&,dur&,,channel
  1749. else
  1750.   segments&=sz&(sn%)\maxsample
  1751.   buf&=buffer&(sn%)
  1752.   szz&=sz&(sn%)
  1753.  
  1754.   '..get the segment pointers
  1755.   for i&=0 to segments&
  1756.     wave_ptr&(i&)=buf&+maxsample*i&
  1757.   next
  1758.  
  1759.   '..play sample in segments
  1760.   for i&=0 to segments&
  1761.     if szz& >= maxsample then 
  1762.        wave channel,wave_ptr&(i&),maxsample 
  1763.        bytes&=maxsample
  1764.     else 
  1765.        wave channel,wave_ptr&(i&),szz&
  1766.        bytes&=szz&
  1767.     end if
  1768.     dur&=.279365*per&*bytes&/1e6*18.2
  1769.     if dur&>1 then dur& = dur&-1
  1770.     sound per&,dur&,,channel
  1771.     szz&=szz&-maxsample
  1772.   next   
  1773. end if
  1774.  
  1775. return