home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / BIPL.ZIP / PROGS.ZIP / SOLIT.ICN < prev    next >
Encoding:
Text File  |  1992-09-28  |  26.4 KB  |  959 lines
  1. ############################################################################
  2. #
  3. #    File:     solit.icn
  4. #
  5. #    Subject:  Program to play solitaire
  6. #
  7. #    Author:   Jerry Nowlin, with changes by Phillip L. Thomas
  8. #              and Ralph Griswold
  9. #
  10. #    Date:     June 3, 1991
  11. #
  12. ###########################################################################
  13. #
  14. #     This program was inspired by a solitaire game that was written
  15. #  by Allyn Wade and copyrighted by him in 1985.  His game was
  16. #  designed for the IBM PC/XT/PCjr with a color or monochrome moni-
  17. #  tor.
  18. #
  19. #     I didn't follow his design exactly because I didn't want to
  20. #  restrict myself to a specific machine.  This program has the
  21. #  correct escape sequences programmed into it to handle several
  22. #  common terminals and PC's.  It's commented well enough that most
  23. #  people can modify the source to work for their hardware.
  24. #
  25. #     These variables must be defined with the correct escape
  26. #  sequences to:
  27. #
  28. #          CLEAR  -  clear the screen
  29. #          CLREOL -  clear to the end of line
  30. #          NORMAL -  turn on normal video for foreground characters
  31. #          RED    -  make the foreground color for characters red
  32. #          BLACK  -  make the foreground color for characters black
  33. #
  34. #  If there is no way to use red and black, the escape sequences
  35. #  should at least make RED and BLACK have different video attri-
  36. #  butes; for example red could have inverse video while black has
  37. #  normal video.
  38. #
  39. #     There are two other places where the code is device dependent.
  40. #  One is in the face() procedure.  The characters used to display
  41. #  the suites of cards can be modified there.  For example, the IBM
  42. #  PC can display actual card face characters while all other
  43. #  machines currently use HDSC for hearts, diamonds, spades and
  44. #  clubs respectively.
  45. #
  46. #     The last, and probably trickiest place is in the movecursor()
  47. #  procedure.  This procedure must me modified to output the correct
  48. #  escape sequence to directly position the cursor on the screen.
  49. #  The comments and 3 examples already in the procedure will help.
  50. #
  51. #     So as not to cast dispersions on Allyn Wade's program, I
  52. #  incorporated the commands that will let you cheat.  They didn't
  53. #  exist in his program.  I also incorporated the auto pilot command
  54. #  that will let the game take over from you at your request and try
  55. #  to win.  I've run some tests, and the auto pilot can win about
  56. #  10% of the games it's started from scratch.  Not great but not
  57. #  too bad.  I can't do much better myself without cheating.  This
  58. #  program is about as totally commented as you can get so the logic
  59. #  behind the auto pilot is fairly easy to understand and modify.
  60. #  It's up to you to make the auto pilot smarter.
  61. #
  62. ############################################################################
  63. #
  64. #  Note:
  65. #
  66. #     The command-line argument, which defaults to support for the VT100,
  67. #  determines the screen driver.  For MS-DOS computers, the ANSI.SYS driver
  68. #  is needed.
  69. #
  70. ############################################################################
  71. #
  72. #  Requires:  keyboard functions
  73. #
  74. ############################################################################
  75.  
  76. global   VERSION, CLEAR, CLREOL, NORMAL, RED, BLACK
  77.  
  78. global   whitespace, amode, seed, deck, over, hidden, run, ace
  79.  
  80. procedure main(args)
  81.    local a, p, c, r, s, cnt, cheat, cmd, act, from, dest
  82.  
  83.    VERSION := (!args == ("Atari ST" | "hp2621" | "IBM PC" | "vt100"))
  84.  
  85. #  if keyboard functions are not available, disable ability to
  86. #  get out of auto mode.
  87.  
  88.    if not(&features == "keyboard functions") then
  89.       stop("*** requires keyboard functions")
  90.  
  91.    case VERSION of {
  92.  
  93.       "Atari ST": {
  94.          CLEAR  := "\eE"
  95.          CLREOL := "\eK"
  96.          NORMAL := "\eb3"
  97.          RED    := "\eb1"
  98.          BLACK  := "\eb2"
  99.       }
  100.  
  101.       "hp2621": {
  102.          CLEAR  := "\eH\eJ"
  103.          CLREOL := "\eK"
  104.          NORMAL := "\e&d@"
  105.          RED    := "\e&dJ"
  106.          BLACK  := "\e&d@"
  107.       }
  108.  
  109.       "IBM PC" | "vt100": {
  110.          CLEAR  := "\e[H\e[2J"
  111.          CLREOL := "\e[0K"
  112.          NORMAL := "\e[0m"
  113.          RED    := "\e[0;31;47m"
  114.          BLACK  := "\e[1;30;47m"
  115.       }
  116.  
  117.       default: {  # same as IBM PC and vt100
  118.          CLEAR  := "\e[H\e[2J"
  119.          CLREOL := "\e[0K"
  120.          NORMAL := "\e[0m"
  121.          RED    := "\e[0;31;47m"
  122.          BLACK  := "\e[1;30;47m"
  123.       }
  124.    }
  125.  
  126.    # white space is blanks or tabs
  127.    whitespace := ' \t'
  128.  
  129.    # clear the auto pilot mode flag
  130.    amode := 0
  131.  
  132.    # if a command line argument started with "seed" use the rest of
  133.    # the argument for the random number generator seed value
  134.    if (a := !args)[1:5] == "seed" then seed := integer(a[5:0])
  135.  
  136.    # initialize the data structures
  137.    deck   := shuffle()
  138.    over   := []
  139.    hidden := [[],[],[],[],[],[],[]]
  140.    run    := [[],[],[],[],[],[],[]]
  141.    ace    := [[],[],[],[]]
  142.  
  143.    # lay down the 7 piles of cards
  144.    every p := 1 to 7 do every c := p to 7 do put(hidden[c],get(deck))
  145.  
  146.    # turn over the top of each pile to start a run
  147.    every r := 1 to 7 do put(run[r],get(hidden[r]))
  148.  
  149.    # check for aces in the runs and move them to the ace piles
  150.    every r := 1 to 7 do while getvalue(run[r][1]) = 1 do {
  151.       s := getsuite(!run[r])
  152.       push(ace[s],get(run[r]))
  153.       put(run[r],get(hidden[r]))
  154.    }
  155.  
  156.    # initialize the command and cheat counts
  157.    cnt := cheat := 0
  158.  
  159.    # clear the screen and display the initial layout
  160.    writes(CLEAR)
  161.    display()
  162.  
  163.    # if a command line argument was "auto" let the auto pilot take over
  164.    if !args == "auto" then autopilot(cheat)
  165.  
  166.    # loop reading commands
  167.    repeat {
  168.  
  169.       # increment the command count
  170.       cnt +:= 1
  171.  
  172.       # prompt for a command
  173.       movecursor(15,0)
  174.       writes("cmd:",cnt,"> ",CLREOL)
  175.  
  176.       # scan the command line
  177.       (cmd := read() | exit()) ? {
  178.  
  179.          # parse the one character action
  180.          tab(many(whitespace))
  181.          act := (move(1) | "")
  182.          tab(many(whitespace))
  183.  
  184.          # switch on the action
  185.          case map(act) of {
  186.  
  187.          # turn on the automatic pilot
  188.          "a": autopilot(cheat)
  189.  
  190.          # move a card or run of cards
  191.          "m": {
  192.             if {from := move(1)
  193.                tab(many(whitespace))
  194.                dest := move(1)
  195.                }                                    # Keep failure of parsing
  196.             then {                                  #   from movecard();
  197.                if not movecard(from,dest) then  {   # otherwise, program
  198.                   whoops(cmd)                       #   aborts.
  199.                   next                              # Exit from wrong
  200.                   }                                 #   instruction.
  201.                else if cardsleft() = 0 then
  202.                   finish(cheat)
  203.                      else &null
  204.                }
  205.            else {                                   # Exit from incomplete
  206.                whoops(cmd)                          #  command.
  207.                next
  208.                }
  209.            }
  210.  
  211.          # thumb the deck
  212.          "t" | "": thumb()
  213.  
  214.          # print some help
  215.          "h" | "?": disphelp()
  216.  
  217.          # print the rules of the game
  218.          "r": disprules()
  219.  
  220.          # give up without winning
  221.          "q": break
  222.  
  223.          # shuffle the deck (cheat!)
  224.          "s": {
  225.             deck |||:= over
  226.             over := []
  227.             deck := shuffle(deck)
  228.             display(["deck"])
  229.             cheat +:= 1
  230.          }
  231.  
  232.          # put hidden cards in the deck (cheat!)
  233.          "p": {
  234.             from := move(1) | whoops(cmd)
  235.             if integer(from) &
  236.                from >= 2 & from <= 7 &
  237.                *hidden[from] > 0 then {
  238.                deck |||:= hidden[from]
  239.                hidden[from] := []
  240.                display(["hide","deck"])
  241.                cheat +:= 1
  242.             } else {
  243.                whoops(cmd)
  244.             }
  245.          }
  246.  
  247.          # print the contents of the deck (cheat!)
  248.          "d": {
  249.             movecursor(17,0)
  250.             write(*deck + *over," card", plural(*deck + *over),
  251.                      " in deck:")
  252.             every writes(face(deck[*deck to 1 by -1])," ")
  253.             every writes(face(!over)," ")
  254.             writes("\nHit RETURN")
  255.             read()
  256.             movecursor(17,0)
  257.             every 1 to 4 do write(CLREOL)
  258.             cheat +:= 1
  259.          }
  260.  
  261.          # print the contents of a hidden pile (cheat!)
  262.          "2" | "3" | "4" | "5" | "6" | "7": {
  263.             movecursor(17,0)
  264.             write(*hidden[act]," cards hidden under run ",
  265.                act)
  266.             every writes(face(!hidden[act])," ")
  267.             writes("\nHit RETURN")
  268.             read()
  269.             movecursor(17,0)
  270.             every 1 to 4 do write(CLREOL)
  271.             cheat +:= 1
  272.          }
  273.  
  274.          # they gave an invalid command
  275.          default: whoops(cmd)
  276.  
  277.          } # end of action case
  278.  
  279.       } # end of scan line
  280.  
  281.    } # end of command loop
  282.  
  283.    # a quit command breaks the loop
  284.    movecursor(16,0)
  285.    writes(CLREOL,"I see you gave up")
  286.    if cheat > 0 then
  287.       write("...even after you cheated ",cheat," time", plural(cheat), "!")
  288.    else
  289.       write("...but at least you didn't cheat...congratulations!")
  290.  
  291.    exit(1)
  292.  
  293. end
  294.  
  295. # this procedure moves cards from one place to another
  296.  
  297. procedure movecard(from,dest,limitmove)
  298.  
  299.    # if from and dest are the same fail
  300.    if from == dest then fail
  301.  
  302.    # move a card from the deck
  303.    if from == "d" then {
  304.  
  305.       # to one of the aces piles
  306.       if dest == "a" then {
  307.          return deck2ace()
  308.  
  309.       # to one of the 7 run piles
  310.       } else if integer(dest) & dest >= 1 & dest <= 7 then {
  311.          return deck2run(dest)
  312.       }
  313.  
  314.    # from one of the 7 run piles
  315.    } else if integer(from) & from >= 1 & from <= 7 then {
  316.  
  317.       # to one of the aces piles
  318.       if dest == "a" then {
  319.          return run2ace(from)
  320.  
  321.  
  322.       # to another of the 7 run piles
  323.       } else if integer(dest) & dest >= 1 & dest <= 7 then {
  324.          return run2run(from,dest,limitmove)
  325.       }
  326.    }
  327.  
  328.    # if none of the correct move combinations were found fail
  329.    fail
  330.  
  331. end
  332.  
  333. procedure deck2run(dest)
  334.    local fcard, dcard, s
  335.  
  336.    # set fcard to the top of the overturned pile or fail
  337.    fcard := (over[1] | fail)
  338.  
  339.    # set dcard to the low card of the run or to null if there are no
  340.    # cards in the run
  341.    dcard := (run[dest][-1] | &null)
  342.  
  343.    # check to see if the move is legal
  344.    if chk2run(fcard,dcard) then {
  345.  
  346.       # move the card and update the display
  347.       put(run[dest],get(over))
  348.       display(["deck",dest])
  349.  
  350.       # while there are aces on the top of the overturned pile
  351.       # move them to the aces piles
  352.       while getvalue(over[1]) = 1 do {
  353.          s := getsuite(over[1])
  354.          push(ace[s],get(over))
  355.          display(["deck","ace"])
  356.       }
  357.       return
  358.    }
  359.  
  360. end
  361.  
  362. procedure deck2ace()
  363.    local fcard, a, s
  364.  
  365.    # set fcard to the top of the overturned pile or fail
  366.    fcard := (over[1] | fail)
  367.  
  368.    # for every ace pile
  369.    every a := !ace do {
  370.  
  371.       # if the top of the ace pile is one less than the from card
  372.       # they are in the same suit and in sequence
  373.       if a[-1] + 1 = fcard then {
  374.  
  375.          # move the card and update the display
  376.          put(a,get(over))
  377.          display(["deck","ace"])
  378.  
  379.          # while there are aces on the top of the overturned
  380.          # pile move them to the aces piles
  381.          while getvalue(over[1]) = 1 do {
  382.             s := getsuite(!over)
  383.             push(ace[s],get(over))
  384.             display(["deck","ace"])
  385.          }
  386.          return
  387.       }
  388.    }
  389.  
  390. end
  391.  
  392. procedure run2ace(from)
  393.    local fcard, a, s
  394.  
  395.    # set fcard to the low card of the run or fail if there are no
  396.    # cards in the run
  397.    fcard := (run[from][-1] | fail)
  398.  
  399.    # for every ace pile
  400.    every a := !ace do {
  401.  
  402.       # if the top of the ace pile is one less than the from card
  403.       # they are in the same suit and in sequence
  404.       if a[-1] + 1 = fcard then {
  405.  
  406.          # move the card and update the display
  407.          put(a,pull(run[from]))
  408.          display([from,"ace"])
  409.  
  410.          # if the from run is now empty and there are hidden
  411.          # cards to expose
  412.          if *run[from] = 0 & *hidden[from] > 0 then {
  413.  
  414.             # while there are aces on the top of the
  415.             # hidden pile move them to the aces piles
  416.             while getvalue(hidden[from][1]) = 1 do {
  417.                s := getsuite(hidden[from][1])
  418.                push(ace[s],get(hidden[from]))
  419.                display(["ace"])
  420.             }
  421.  
  422.             # put the top hidden card in the empty run
  423.             # and display the hidden counts
  424.             put(run[from],get(hidden[from]))
  425.             display(["hide"])
  426.          }
  427.  
  428.          # update the from run display
  429.          display([from])
  430.          return
  431.       }
  432.    }
  433.  
  434. end
  435.  
  436. procedure run2run(from,dest,limitmove)
  437.    local fcard, dcard, s
  438.  
  439.    # set fcard to the high card of the run or fail if there are no
  440.    # cards in the run
  441.    fcard := (run[from][1] | fail)
  442.  
  443.    # set dcard to the low card of the run or null if there are no
  444.    # cards in the run
  445.    dcard := (run[dest][-1] | &null)
  446.  
  447.    # avoid king thrashing in automatic mode (there's no point in
  448.    # moving a king high run to an empty run if there are no hidden
  449.    # cards under the king high run to be exposed)
  450.    if amode > 0 & /dcard & getvalue(fcard) = 13 & *hidden[from] = 0 then
  451.       fail
  452.  
  453.    # avoid wasted movement if the limit move parameter was passed
  454.    # (there's no point in moving a pile if there are no hidden cards
  455.    # under it unless you have a king in the deck)
  456.    if amode > 0 & \limitmove & *hidden[from] = 0 then fail
  457.  
  458.    # check to see if the move is legal
  459.    if chk2run(fcard,dcard) then {
  460.  
  461.       # add the from run to the dest run
  462.       run[dest] |||:= run[from]
  463.  
  464.       # empty the from run
  465.       run[from] := []
  466.  
  467.       # display the updated runs
  468.       display([from,dest])
  469.  
  470.       # if there are hidden cards to expose
  471.       if *hidden[from] > 0 then {
  472.  
  473.          # while there are aces on the top of the hidden
  474.          # pile move them to the aces piles
  475.          while getvalue(hidden[from][1]) = 1 do {
  476.             s := getsuite(hidden[from][1])
  477.             push(ace[s],get(hidden[from]))
  478.             display(["ace"])
  479.          }
  480.  
  481.          # put the top hidden card in the empty run and
  482.          # display the hidden counts
  483.          put(run[from],get(hidden[from]))
  484.          display(["hide"])
  485.       }
  486.  
  487.       # update the from run display
  488.       display([from])
  489.       return
  490.    }
  491.  
  492. end
  493.  
  494. procedure chk2run(fcard,dcard)
  495.  
  496.    # if dcard is null the from card must be a king or
  497.    if ( /dcard & (getvalue(fcard) = 13 | fail) ) |
  498.  
  499.    # if the value of dcard is one more than fcard and
  500.       ( getvalue(dcard) - 1 = getvalue(fcard) &
  501.  
  502.    # their colors are different they can be moved
  503.         getcolor(dcard) ~= getcolor(fcard) ) then return
  504.  
  505. end
  506.  
  507. # this procedure finishes a game where there are no hidden cards left and the
  508. # deck is empty
  509.  
  510. procedure finish(cheat)
  511.  
  512.    movecursor(16,0)
  513.    writes("\007I'll finish for you now...\007")
  514.  
  515.    # finish moving the runs to the aces piles
  516.    while movecard(!"7654321","a")
  517.  
  518.    movecursor(16,0)
  519.    writes(CLREOL,"\007You WIN\007")
  520.  
  521.    if cheat > 0 then
  522.       write("...but you cheated ", cheat, " time", plural(cheat), "!")
  523.    else
  524.       write("...and without cheating...congratulations!")
  525.  
  526.    exit(0)
  527.  
  528. end
  529.  
  530. # this procedure takes over and plays the game for you
  531.  
  532. procedure autopilot(cheat)
  533.    local tseq, totdeck
  534.  
  535.    movecursor(16,0)
  536.    writes("Going into automatic mode...")
  537.    if proc(kbhit) then writes( " [Press any key to return.]")
  538.    writes(CLREOL)
  539.  
  540.    # set auto pilot mode
  541.    amode := 1
  542.  
  543.    # while there are cards that aren't in runs or the aces piles
  544.    while (cardsleft()) > 0 do {
  545.  
  546.       # try to make any run to run plays that will uncover
  547.       # hidden cards
  548.       while movecard(!"7654321",!"1234567","hidden")
  549.  
  550.       # try for a move that will leave an empty spot
  551.       if movecard(!"7654321",!"1234567") then next
  552.  
  553.       # if there's no overturned card thumb the deck
  554.       if *over = 0 then thumb()
  555.  
  556.       # initialize the thumbed sequence set
  557.       tseq := set()
  558.  
  559.       # try thumbing the deck for a play
  560.       totdeck := *deck + *over
  561.       every 1 to totdeck do {
  562.          if movecard("d",!"1234567a") then break
  563.  
  564.          if kbhit() then {
  565.             movecursor(16,0)
  566.             write("Now in manual mode ...", CLREOL)
  567.             amode := 0
  568.             return
  569.             }
  570.          insert(tseq,over[1])
  571.          thumb()
  572.       }
  573.  
  574.       # if we made a deck to somewhere move continue
  575.       if totdeck > *deck + *over then next
  576.  
  577.       # try for a run to ace play
  578.       if movecard(!"7654321","a") then next
  579.  
  580.       # if we got this far and couldn't play give up
  581.       break
  582.    }
  583.  
  584.    # position the cursor for the news
  585.    movecursor(16,30)
  586.  
  587.    # if all the cards are in runs or the aces piles
  588.    if cardsleft() = 0 then {
  589.  
  590.       writes("\007YEA...\007", CLREOL)
  591.  
  592.       # finish moving the runs to the aces piles
  593.       while movecard(!"7654321","a")
  594.  
  595.       movecursor(16,37)
  596.       write("I won!!!!!")
  597.       if cheat > 0 then write("But you cheated ", cheat, " time",
  598.             plural(cheat), ".")
  599.  
  600.       exit(0)
  601.  
  602.    } else {
  603.  
  604.       writes("I couldn't win this time.", CLREOL)
  605.       if cheat > 0 then writes(" But you cheated ", cheat, " time",
  606.                plural(cheat), ".")
  607.  
  608.       # print the information needed to verify that the
  609.       # program couldn't win
  610.  
  611.       movecursor(17,0)
  612.       writes(*deck + *over," card", plural(*deck + *over),
  613.                " in deck.")
  614.       if *tseq > 0 then {
  615.          write("  Final thumbing sequence:")
  616.          every writes(" ",face(!tseq))
  617.       }
  618.       write()
  619.  
  620.       exit(1)
  621.  
  622.    }
  623.  
  624. end
  625.  
  626. # this procedure updates the display
  627.  
  628. procedure display(parts)
  629.    local r, a, h, c, part, l
  630.  
  631.    static   long  # a list with the length of each run
  632.  
  633.    initial {
  634.       long := [1,1,1,1,1,1,1]
  635.    }
  636.  
  637.    # if the argument list is empty or contains "all" update all parts
  638.    # of the screen
  639.    if /parts | !parts == "all" then {
  640.       long  := [1,1,1,1,1,1,1]
  641.       parts := [  "label","hide","ace","deck",
  642.             "1","2","3","4","5","6","7" ]
  643.    }
  644.  
  645.    # for every part in the argument list
  646.    every part := !parts do case part of {
  647.  
  648.       # display the run number, aces and deck labels
  649.       "label" : {
  650.          every r := 1 to 7 do {
  651.             movecursor(1,7+(r-1)*5)
  652.             writes(r)
  653.          }
  654.          movecursor(1,56)
  655.          writes("ACES")
  656.          movecursor(6,56)
  657.          writes("DECK")
  658.       }
  659.  
  660.       # display the hidden card counts
  661.       "hide" : {
  662.          every r := 1 to 7 do {
  663.             movecursor(1,9+(r-1)*5)
  664.             writes(0 < *hidden[r] | " ")
  665.          }
  666.       }
  667.  
  668.       # display the aces piles
  669.       "ace" : {
  670.          movecursor(3,49)
  671.          every a := 1 to 4 do
  672.             writes(face(ace[a][-1]) | "---","  ")
  673.       }
  674.  
  675.       # display the deck and overturned piles
  676.       "deck" : {
  677.          movecursor(8,54)
  678.          writes((*deck > 0 , " # ") | "   ","  ")
  679.          writes(face(!over) | "   ","  ")
  680.       }
  681.  
  682.       # display the runs piles
  683.       "1" | "2" | "3" | "4" | "5" | "6" | "7" : {
  684.          l := ((long[part] > *run[part]) | long[part])
  685.          h := ((long[part] < *run[part]) | long[part])
  686.          l <:= 1
  687.          every c := l to h do {
  688.             movecursor(c+1,7+(part-1)*5)
  689.             writes(face(run[part][c]) | "   ")
  690.          }
  691.          long[part] := *run[part]
  692.       }
  693.    }
  694.  
  695.    return
  696.  
  697. end
  698.  
  699. # A correction to my corrections for solit.icn.
  700. # The zero case never happens in solit.icn, but this
  701. #     procedure is more general. From Phillip L. Thomas:
  702.  
  703. # Return "s" for values equal to 0 or greater than 1, e.g.,
  704. #     0 horses, 1 horse, 2 horses.
  705.  
  706. procedure plural(n)
  707.    /n := 0                             # Handle &null values.
  708.    if n = 1 then return ""
  709.    else return "s"
  710. end
  711.  
  712. # this procedure thumbs the deck 3 cards at a time
  713.  
  714. procedure thumb()
  715.    local s
  716.  
  717.    # if the deck is all thumbed
  718.    if *deck = 0 then {
  719.  
  720.       # if there are no cards in the overturned pile either return
  721.       if *over = 0 then return
  722.  
  723.       # turn the overturned pile back over
  724.       while put(deck,pull(over))
  725.    }
  726.  
  727.    # turn over 3 cards or at least what's left
  728.    every 1 to 3 do if *deck > 0 then push(over,get(deck))
  729.  
  730.    display(["deck"])
  731.  
  732.    # while there are aces on top of the overturned pile move them to
  733.    # the aces pile
  734.    while getvalue(over[1]) = 1 do {
  735.       s := getsuite(over[1])
  736.       push(ace[s],get(over))
  737.       display(["deck","ace"])
  738.    }
  739.  
  740.    # if the overturned pile is empty again and there are still cards
  741.    # in the deck thumb again (this will only happen if the top three
  742.    # cards in the deck were aces...not likely but)
  743.    if *over = 0 & *deck > 0 then thumb()
  744.  
  745.    return
  746.  
  747. end
  748.  
  749. # this procedure shuffles a deck of cards
  750.  
  751. procedure shuffle(cards)
  752.  
  753.    static   fulldeck # the default shuffle is a full deck of cards
  754.  
  755.    initial {
  756.       # set up a full deck of cards
  757.       fulldeck := []
  758.       every put(fulldeck,1 to 52)
  759.  
  760.       # if seed isn't already set use the time to set it
  761.       if /seed then seed := integer(&clock[1:3] ||
  762.                      &clock[4:6] ||
  763.                      &clock[7:0])
  764.  
  765.       # seed the random number generator for the first time
  766.       &random := seed
  767.    }
  768.  
  769.    # if no cards were passed use the full deck
  770.    /cards := fulldeck
  771.  
  772.    # copy the cards (shuffling is destructive)
  773.    deck := copy(cards)
  774.  
  775.    # shuffle the deck
  776.    every !deck :=: ?deck
  777.  
  778.    return deck
  779.  
  780. end
  781.  
  782. procedure face(card)
  783.  
  784.    static   cstr, # the list of card color escape sequences
  785.       vstr, # the list of card value labels
  786.       sstr  # the list of card suite labels
  787.  
  788.    initial {
  789.       cstr := [RED,BLACK]
  790.       vstr := ["A",2,3,4,5,6,7,8,9,10,"J","Q","K"]
  791.       if \VERSION == "IBM PC" then
  792.          sstr := ["\003","\004","\005","\006"]
  793.       else
  794.          sstr := ["H","D","S","C"]
  795.    }
  796.  
  797.    # return a string containing the correct color change escape sequence,
  798.    # the value and suite labels right justified in 3 characters,
  799.    # and the back to normal escape sequence
  800.    return   cstr[getcolor(card)] ||
  801.       right(vstr[getvalue(card)] || sstr[getsuite(card)],3) ||
  802.       NORMAL
  803.  
  804. end
  805.  
  806. # a deck of cards is made up of 4 suites of 13 values; 1-13, 14-26, etc.
  807.  
  808. procedure getvalue(card)
  809.  
  810.    return (card-1) % 13 + 1
  811.  
  812. end
  813.  
  814. # each suite of cards is made up of ace - king (1-13)
  815.  
  816. procedure getsuite(card)
  817.  
  818.    return (card-1) / 13 + 1
  819.  
  820. end
  821.  
  822. # the first two suites are hearts and diamonds so all cards 1-26 are red
  823. # and all cards 27-52 are black.
  824.  
  825. procedure getcolor(card)
  826.  
  827.    return (card-1) / 26 + 1
  828.  
  829. end
  830.  
  831. # this procedure counts cards that aren't in runs or the aces piles
  832.  
  833. procedure cardsleft()
  834.    local totleft
  835.  
  836.    # count the cards left in the deck and the overturned pile
  837.    totleft := *deck + *over
  838.  
  839.    # add in the hidden cards
  840.    every totleft +:= *!hidden
  841.  
  842.    return totleft
  843.  
  844. end
  845.  
  846. # this procedure implements a device dependent cursor positioning scheme
  847.  
  848. procedure movecursor(line,col)
  849.  
  850.    if \VERSION == "Atari ST" then
  851.       writes("\eY",&ascii[33+line],&ascii[33+col])
  852.  
  853.    else if \VERSION == "hp2621" then
  854.       writes("\e&a",col,"c",line,"Y")
  855.  
  856.    else
  857.       writes("\e[",line,";",col,"H")
  858.  
  859. end
  860.  
  861. # all invalid commands call this procedure
  862.  
  863. procedure whoops(cmd)
  864.    local i, j
  865.  
  866.    movecursor(15,0)
  867.    writes("\007Invalid Command: '",cmd,"'\007")
  868.  
  869.    # this delay loop can be diddled for different machines
  870.    every i := 1 to 500 do j := i
  871.  
  872.    movecursor(15,0)
  873.    writes("\007",CLREOL,"\007")
  874.  
  875.    return
  876.  
  877. end
  878.  
  879. # display the help message
  880.  
  881. procedure disphelp()
  882.  
  883.    static   help
  884.  
  885.    initial {
  886.       help := [
  887. "Commands: t or RETURN     : thumb the deck 3 cards at a time",
  888. "          m [d1-7] [1-7a] : move cards or runs",
  889. "          a               : turn on the auto pilot (in case you get stuck)",
  890. "          s               : shuffle the deck (cheat!)",
  891. "          p [2-7]         : put a hidden pile into the deck (cheat!)",
  892. "          d               : print the cards in the deck (cheat!)",
  893. "          [2-7]           : print the cards in a hidden pile (cheat!)",
  894. "          h or ?          : print this command summary",
  895. "          r               : print the rules of the game",
  896. "          q               : quit",
  897. "",
  898. "Moving:   1-7, 'd', or 'a' select the source and destination for a move. ",
  899. "          Valid moves are from a run to a run, from the deck to a run,",
  900. "          from a run to an ace pile, and from the deck to an ace pile.",
  901. "",
  902. "Cheating: Commands that allow cheating are available but they will count",
  903. "          against you in your next life!"
  904.       ]
  905.    }
  906.  
  907.    writes(CLEAR)
  908.    every write(!help)
  909.    writes("Hit RETURN")
  910.    read()
  911.    writes(CLEAR)
  912.    display()
  913.    return
  914.  
  915. end
  916.  
  917. # display the rules message
  918.  
  919. procedure disprules()
  920.  
  921.    static   rules
  922.  
  923.    initial {
  924.       rules := [
  925. "Object:   The object of this game is to get all of the cards in each suit",
  926. "          in order on the proper ace pile.",
  927. "                                        ",
  928. "Rules:    Cards are played on the ace piles in ascending order: A,2,...,K. ",
  929. "          All aces are automatically placed in the correct aces pile as",
  930. "          they're found in the deck or in a pile of hidden cards.  Once a",
  931. "          card is placed in an ace pile it can't be removed.",
  932. "",
  933. "          Cards must be played in descending order: K,Q,..,2, on the seven",
  934. "          runs which are initially dealt.  They must always be played on a",
  935. "          card of the opposite color.  Runs must always be moved as a",
  936. "          whole, unless you're moving the lowest card on a run to the",
  937. "          correct ace pile.",
  938. "",
  939. "          Whenever a whole run is moved, the top hidden card is turned",
  940. "          over, thus becoming the beginning of a new run.  If there are no",
  941. "          hidden cards left, a space is created which can only be filled by",
  942. "          a king.",
  943. "",
  944. "          The rest of the deck is thumbed 3 cards at a time, until you spot",
  945. "          a valid move.  Whenever the bottom of the deck is reached, the",
  946. "          cards are turned over and you can continue thumbing."
  947.       ]
  948.    }
  949.  
  950.    writes(CLEAR)
  951.    every write(!rules)
  952.    writes("Hit RETURN")
  953.    read()
  954.    writes(CLEAR)
  955.    display()
  956.    return
  957.  
  958. end
  959.