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