home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / nfsrc21.zip / PEGS.PRG < prev    next >
Text File  |  1991-09-28  |  9KB  |  241 lines
  1. /*
  2.  * File......: PEGS.PRG
  3.  * Author....: Greg Lief
  4.  * CIS ID....: 72460,1760
  5.  * Date......: $Date:   28 Sep 1991 03:09:44  $
  6.  * Revision..: $Revision:   1.3  $
  7.  * Log file..: $Logfile:   E:/nanfor/src/pegs.prv  $
  8.  *
  9.  * This function is an original work by Mr. Grump and is placed in the
  10.  * public domain.
  11.  *
  12.  * Modification history:
  13.  * ---------------------
  14.  *
  15.  * $Log:   E:/nanfor/src/pegs.prv  $
  16.  * 
  17.  *    Rev 1.3   28 Sep 1991 03:09:44   GLENN
  18.  * Allowed "No peg at that location" messagee to exceed the boundary of the
  19.  * box at the bottom of the matrix.  Just shortened the message to "No 
  20.  * piece there, per Greg's instructions.
  21.  * 
  22.  *    Rev 1.2   15 Aug 1991 23:04:18   GLENN
  23.  * Forest Belt proofread/edited/cleaned up doc
  24.  * 
  25.  *    Rev 1.1   14 Jun 1991 19:52:38   GLENN
  26.  * Minor edit to file header
  27.  * 
  28.  *    Rev 1.0   01 Apr 1991 01:02:00   GLENN
  29.  * Nanforum Toolkit
  30.  *
  31.  */
  32.  
  33. /*  $DOC$
  34.  *  $FUNCNAME$
  35.  *     FT_PEGS()
  36.  *  $CATEGORY$
  37.  *     Game
  38.  *  $ONELINER$
  39.  *     FT_PEGS GAME (all work and no play...)
  40.  *  $SYNTAX$
  41.  *     FT_PEGS() -> NIL
  42.  *  $ARGUMENTS$
  43.  *     None
  44.  *  $RETURNS$
  45.  *     NIL
  46.  *  $DESCRIPTION$
  47.  *     This function can be used to alleviate boredom.  The object is to
  48.  *     remove all pegs except one.  This is done by jumping over adjacent
  49.  *     pegs.
  50.  *  $EXAMPLES$
  51.  *     FT_PEGS()
  52.  *  $END$
  53.  */
  54.  
  55. #include "inkey.ch"
  56. #translate SINGLEBOX(<top>, <left>, <bottom>, <right>) => ;
  57.            @ <top>, <left>, <bottom>, <right> BOX "┌─┐│┘─└│ "
  58. #translate DOUBLEBOX(<top>, <left>, <bottom>, <right>) => ;
  59.            @ <top>, <left>, <bottom>, <right> BOX '╔═╗║╝═╚║ '
  60. memvar getlist
  61.  
  62. /*
  63.    here's the board array -- structure of which is:
  64.    board_[xx, 1] = subarray containing box coordinates for this peg
  65.    board_[xx, 2] = subarray containing all adjacent locations
  66.    board_[xx, 3] = subarray containing all target locations
  67.    board_[xx, 4] = is the location occupied or not? .T. = Yes, .F. = No
  68. */
  69. static board_ := { { {0, 29, 2, 34}, {2, 4}, {3, 9}, .T. } , ;
  70.              { {0, 37, 2, 42}, {5}, {10}, .T.}      , ;
  71.              { {0, 45, 2, 50}, {2, 6}, {1, 11}, .T. } , ;
  72.              { {3, 29, 5, 34}, {5, 9}, {6, 16}, .T. } , ;
  73.              { {3, 37, 5, 42}, {10}, {17}, .T. } , ;
  74.              { {3, 45, 5, 50}, {5, 11}, {4, 18}, .T. } , ;
  75.              { {6, 13, 8, 18}, {8, 14}, {9, 21}, .T. } , ;
  76.              { {6, 21, 8, 26}, {9, 15}, {10, 22}, .T. } , ;
  77.              { {6, 29, 8, 34}, {4, 8, 10, 16}, {1, 7, 11, 23}, .T. } , ;
  78.              { {6, 37, 8, 42}, {5, 9, 11, 17}, {2, 8, 12, 24}, .T. } , ;
  79.              { {6, 45, 8, 50}, {6, 10, 12, 18}, {3, 9, 13, 25}, .T. } , ;
  80.              { {6, 53, 8, 58}, {11, 19}, {10, 26}, .T. } , ;
  81.              { {6, 61, 8, 66}, {12, 20}, {11, 27}, .T. } , ;
  82.              { {9, 13, 11, 18}, {15}, {16}, .T. } , ;
  83.              { {9, 21, 11, 26}, {16}, {17}, .T. } , ;
  84.              { {9, 29, 11, 34}, {9, 15, 17, 23}, {4, 14, 18, 28}, .T. } , ;
  85.              { {9, 37, 11, 42}, {10, 16, 18, 24}, {5, 15, 19, 29}, .F. } , ;
  86.              { {9, 45, 11, 50}, {11, 17, 19, 25}, {6, 16, 20, 30}, .T. } , ;
  87.              { {9, 53, 11, 58}, {18}, {17}, .T. } , ;
  88.              { {9, 61, 11, 66}, {19}, {18}, .T. } , ;
  89.              { {12, 13, 14, 18}, {14, 22}, {7, 23}, .T. } , ;
  90.              { {12, 21, 14, 26}, {15, 23}, {8, 24}, .T. } , ;
  91.              { {12, 29, 14, 34}, {16, 22, 24, 28}, {9, 21, 25, 31}, .T. } , ;
  92.              { {12, 37, 14, 42}, {17, 23, 25, 29}, {10, 22, 26, 32}, .T. } , ;
  93.              { {12, 45, 14, 50}, {18, 24, 26, 30}, {11, 23, 27, 33}, .T. } , ;
  94.              { {12, 53, 14, 58}, {19, 25}, {12, 24}, .T. } , ;
  95.              { {12, 61, 14, 66}, {20, 26}, {13, 25}, .T. } , ;
  96.              { {15, 29, 17, 34}, {23, 29}, {16, 30}, .T. } , ;
  97.              { {15, 37, 17, 42}, {24}, {17}, .T. } , ;
  98.              { {15, 45, 17, 50}, {25, 29}, {18, 28}, .T. } , ;
  99.              { {18, 29, 20, 34}, {28, 32}, {23, 33}, .T. } , ;
  100.              { {18, 37, 20, 42}, {29}, {24}, .T. } , ;
  101.              { {18, 45, 20, 50}, {30, 32}, {25, 31}, .T. } }
  102.  
  103. function FT_PEGS
  104. LOCAL XX, MOVE, MPOS, POSSIBLE_, BUFFER, TOPROW, OLDSCORE, MOVE2, ;
  105.       SCANBLOCK, OLDCOLOR := SETCOLOR('w/n'), ;
  106.       oldscrn := savescreen(0, 0, maxrow(), maxcol())
  107. /*
  108.    the following code block is used in conjunction with ASCAN()
  109.    to validate entry when there is more than one possible move
  110. */
  111. scanblock := { | a | a[2] == move2 }
  112. cls
  113. xx := 1
  114. setcolor('w/r')
  115. SINGLEBOX(22, 31, 24, 48)
  116. @ 23, 33 say "Your move:"
  117. aeval(board_, { | a, x | drawbox(x) } )
  118. do while lastkey() != K_ESC .and. moremoves()
  119.    move := 1
  120.    setcolor('w/n')
  121.    @ 23, 44 get move picture '##' range 1, 33
  122.    read
  123.    if move > 0
  124.       do case
  125.          case ! board_[move][4]
  126.             err_msg("No piece there!")
  127.          otherwise
  128.             possible_ := {}
  129.             for xx := 1 to len(board_[move][2])
  130.                if board_[board_[move][2,xx] ][4] .and. ;
  131.                   ! board_[board_[move][3,xx] ][4]
  132.                   aadd(possible_, { board_[move][2,xx], board_[move][3,xx] })
  133.                endif
  134.             next
  135.             // only one available move -- do it
  136.             do case
  137.                case len(possible_) = 1
  138.                   // clear out original position and the position you jumped over
  139.                   board_[move][4] := board_[possible_[1, 1] ][4] := .F.
  140.                   board_[possible_[1, 2] ][4] := .T.
  141.                   drawbox(move, board_[move])
  142.                   drawbox(possible_[1,1])
  143.                   drawbox(possible_[1,2])
  144.                case len(possible_) = 0
  145.                   err_msg('Illegal move!')
  146.                otherwise
  147.                   move2 := possible_[1, 2]
  148.                   toprow := 21 - len(possible_)
  149.                   setcolor('+w/b')
  150.                   buffer := savescreen(toprow, 55, 22, 74)
  151.                   DOUBLEBOX(toprow, 55, 22, 74)
  152.                   @ toprow, 58 say 'Possible Moves'
  153.                   devpos(toprow, 65)
  154.                   aeval(possible_, { | a | devpos(row()+1, 65), ;
  155.                                            devoutpict(a[2], '##') } )
  156.                   oldscore := set(_SET_SCOREBOARD, .f.)
  157.                   @23, 44 get move2 picture '##' ;
  158.                           valid ascan(possible_, scanblock) > 0
  159.                   read
  160.                   restscreen(toprow, 55, 22, 74, buffer)
  161.                   set(_SET_SCOREBOARD, oldscore)
  162.                   mpos := ascan(possible_, { | a | move2 == a[2] })
  163.                   // clear out original position and the position you jumped over
  164.                   board_[move][4] := board_[possible_[mpos, 1] ][4] := .F.
  165.                   board_[move2][4] := .T.
  166.                   drawbox(move)
  167.                   drawbox(possible_[mpos,1])
  168.                   drawbox(move2)
  169.  
  170.             endcase
  171.       endcase
  172.       move := 1
  173.    endif
  174. enddo
  175. setcolor(oldcolor)
  176. restscreen(0, 0, maxrow(), maxcol(), oldscrn)
  177. return NIL
  178.  
  179. * end function FT_PEGS()
  180. *--------------------------------------------------------------------*
  181.  
  182.  
  183. static function DrawBox(nelement)
  184. setcolor(if(board_[nelement][4], '+w/rb', 'w/n'))
  185. @ board_[nelement][1,1], board_[nelement][1,2], board_[nelement][1,3], ;
  186.   board_[nelement][1,4] box "┌─┐│┘─└│ "
  187. DevPos(board_[nelement][1,1] + 1, board_[nelement][1,2] + 2)
  188. DevOut(ltrim(str(nelement)))
  189. return NIL
  190.  
  191. * end static function DrawBox()
  192. *--------------------------------------------------------------------*
  193.  
  194.  
  195. static function err_msg(msg)
  196. local buffer := savescreen(23, 33, 23, 47)
  197. setcursor(0)
  198. setcolor('+w/r')
  199. @ 23, 33 say msg
  200. inkey(2)
  201. setcursor(1)
  202. restscreen(23, 33, 23, 47, buffer)
  203. return nil
  204.  
  205. * end static function Err_Msg()
  206. *--------------------------------------------------------------------*
  207.  
  208.  
  209. static function moremoves()
  210. local xx, yy, canmove := .f., piecesleft := 0, buffer
  211. for xx := 1 to 33
  212.    for yy := 1 to len(board_[xx][2])
  213.       if board_[xx][4] .and.  ;            // if current location is filled
  214.             board_[board_[xx][2,yy] ][4] .and. ;  // adjacent must be filled
  215.             ! board_[board_[xx][3,yy] ][4]           // target must be empty
  216.          canmove := .t.
  217.          exit
  218.       endif
  219.    next
  220.    // increment number of pieces left
  221.    if board_[xx][4]
  222.       piecesleft++
  223.    endif
  224. next
  225. if ! canmove
  226.    setcolor('+w/b')
  227.    buffer := savescreen(18, 55, 21, 74)
  228.    DOUBLEBOX(18, 55, 21, 74)
  229.    @ 19, 58 say "No more moves!"
  230.    @ 20, 58 say ltrim(str(piecesleft)) + " pieces left"
  231.    inkey(0)
  232.    restscreen(18, 55, 21, 74, buffer)
  233. endif
  234. return canmove
  235.  
  236. * end static function MoreMoves()
  237. *--------------------------------------------------------------------*
  238.  
  239. * eof pegs.prg
  240. 
  241.