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 / yahtz.icn < prev    next >
Text File  |  2000-07-29  |  15KB  |  576 lines
  1. ############################################################################
  2. #
  3. #    File:     yahtz.icn
  4. #
  5. #    Subject:  Program to play yahtzee
  6. #
  7. #    Author:   Chris Tenaglia
  8. #
  9. #    Date:     March 3, 1996
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #    Version:  1.3
  18. #
  19. ############################################################################
  20. #
  21. #  Modified by Richard Goerwitz with corrections by Phillip Lee Thomas
  22. #
  23. ############################################################################
  24. #
  25. #  This hacked version will run under UNIX, and under DOS as well.  It
  26. #  should run out of the box on DOS as long as you stay in the current
  27. #  directory.  See the README file.
  28. #
  29. #  This is a test version!!  In accordance with the author's wishes,
  30. #  I'd like to make it clear that I've altered all the screen I/O
  31. #  routines, and have removed characters peculiar to VT terminals.
  32. #  I've tried to keep intact the author's indentation and brace style.
  33. #  Changes, where present, have been indicated by my initials.  The
  34. #  IPL-style header was added by me.
  35. #
  36. #  -Richard Goerwitz.
  37. #
  38. ############################################################################
  39. #
  40. #  Links:  iolib, random
  41. #
  42. ############################################################################
  43.  
  44. link iolib
  45. link random
  46.  
  47. global players,slot,team,d,od,dice,round
  48. procedure main(param)
  49.   paint()
  50.   assign_players()
  51.   every round := 1 to 13 do
  52.     every play(!team)
  53.   summarize()
  54.   end
  55.  
  56. #
  57. # DISPLAYS THE HEADER AND SEPARATOR LINE AT BEGINNING OF GAME
  58. #
  59. procedure paint()
  60.   # Clear first, separately.  Screws up on some terminals of you don't.
  61.   writes(cls())
  62.   # Check to be sure the terminal is big enough, and won't leave magic
  63.   # cookies on the screen.  -RLG
  64.   if getval("ug"|"sg") > 0
  65.   then stop("abort:  Can't do magic cookie terminals!") 
  66.   if getval("li") < 24 | getval("co") < 80 then
  67.     stop("abort:  Your terminal is too small!")
  68.   write(high(uhalf("             Y A H T Z E E              ")))
  69.   write(high(lhalf("             Y A H T Z E E              ")))
  70.   write(at(1,10),graf(repl("=",75)))
  71.   end
  72.  
  73. #
  74. # DISPLAYS THE FINAL SCORE OF ALL THE PLAYERS
  75. #
  76. procedure summarize()
  77.   local player, card, top, bottom, i
  78.  
  79.   # blink, high, inverse was just too much for my terminal to handle -RLG
  80.   write(at(1,11), high(chop("Final Score Summary")))
  81.   every player := key(players) do
  82.     {
  83.     card := players[player]
  84.     top  := 0 ; every i := 1 to 6 do top +:= card[i]
  85.     if top > 62 then top +:= 35
  86.     bottom := 0 ; every i := 7 to 13 do bottom +:= card[i]
  87.     write("Player ",high(left(player,14))," Top = ",right(top,5),
  88.                                        " Bottom = ",right(bottom,5),
  89.                                        "  Total = ",right(top+bottom,5))
  90.     }
  91.   input("<press return>")
  92.   end
  93.  
  94. #
  95. # SETUP AND INITIALIZATION OF YAHTZEE ENVIRONMENT
  96. #
  97. procedure assign_players()
  98.   local n, player
  99.  
  100.   n := 1 ; team := [] ; slot := [] ; d := list(6,"") ; od := list(5,0)
  101.   randomize()
  102.   players := table("n/a")
  103.   repeat
  104.     {
  105.     (player := input(("Name of player #" || n || ": "))) |
  106.       stop("Game called off.")
  107.     if player == "" then break
  108.     n +:= 1
  109.     put(team,player)
  110.     players[player] := list(13,"*")
  111.     }
  112.   if n = 1 then stop("Nobody wants to play!")
  113.  
  114.   put(slot,"Ones")   ; put(slot,"Twos")  ; put(slot,"Threes")
  115.   put(slot,"Fours")  ; put(slot,"Fives") ; put(slot,"Sixes")
  116.   put(slot,"3oK")    ; put(slot,"4oK")   ; put(slot,"FullH")
  117.   put(slot,"SmStr")  ; put(slot,"LgStr") ; put(slot,"Yahtzee")
  118.   put(slot,"Chance")
  119.  
  120.   # VT-specific characters removed.  -RLG
  121.   d[1] := "+-----+|     ||  o  ||     |+-----+"
  122.   d[2] := "+-----+|     || o o ||     |+-----+"
  123.   d[3] := "+-----+|o    ||  o  ||    o|+-----+"
  124.   d[4] := "+-----+|o   o||     ||o   o|+-----+"
  125.   d[5] := "+-----+|o   o||  o  ||o   o|+-----+"
  126.   d[6] := "+-----+|o o o||     ||o o o|+-----+"
  127.   end
  128.  
  129. #
  130. # THIS ROUTINE LETS A PLAYER TAKE THEIR TURN
  131. #
  132. procedure play(name)
  133.   local shake, select
  134.  
  135.   writes(at(1,11),"It's ",high(name),"'s turn",chop())
  136.   writes(at(1,getval("li")-1),high(name))
  137.   input(", please press <RETURN> to begin.")
  138.   score(name)
  139.   dice := [] ; every 1 to 5 do put(dice,?6)
  140.   depict()
  141.   shake := obtain("Shake which ones : ")
  142.   (shake === []) | (every dice[!shake] := ?6)
  143.   depict()
  144.   shake := obtain("Shake which ones (last chance) : ")
  145.   (shake === []) | (every dice[!shake] := ?6)
  146.   depict()
  147.   repeat
  148.     {
  149.     select := input(at(1,22) || clip("Tally to which category (1-13) : "))
  150.     numeric(select)                | next
  151.     (1 <= select <= 13)            | next
  152.     (players[name][select] == "*") | next
  153.     break
  154.     }
  155.   tally(name,select)
  156.   score(name)
  157.   input(at(1,22) || clip("Press <RETURN>"))
  158.   end
  159.  
  160. #
  161. # THIS ROUTINE DRAWS THE DICE
  162. #
  163. procedure depict()
  164.   local i, j, x
  165.  
  166.   every i := 1 to 5 do
  167.     {
  168.     x := 1
  169.     writes(at(i*10+3,3),inverse(i))
  170.     writes(at(i*10+4,9),inverse(dice[i]))  
  171.     every j := 4 to 8 do
  172.       {                   # debug
  173.       writes(at(i*10,j),graf(d[dice[i]][x:x+7]))
  174.       x +:= 7
  175.       }
  176.     od[i] := dice[i]
  177.     }
  178.   end
  179.  
  180. #
  181. # THIS ROUTINE LETS THE PLAYER DECIDE WHAT TO APPLY THE SHAKES TO
  182. #
  183. procedure tally(name,area)
  184.   local sum, unit, flag, tmp, piece, hold
  185.  
  186.   case integer(area) of
  187.     {
  188.     1 : {                        # ones
  189.         sum := 0 ; every unit := !dice do if unit = 1 then sum +:= 1
  190.         players[name][1] := sum
  191.         }
  192.     2 : {                        # twos
  193.         sum := 0 ; every unit := !dice do if unit = 2 then sum +:= 2
  194.         players[name][2] := sum
  195.         }
  196.     3 : {                        # threes
  197.         sum := 0 ; every unit := !dice do if unit = 3 then sum +:= 3
  198.         players[name][3] := sum
  199.         }
  200.     4 : {                        # fours
  201.         sum := 0 ; every unit := !dice do if unit = 4 then sum +:= 4
  202.         players[name][4] := sum
  203.         }
  204.     5 : {                        # fives
  205.         sum := 0 ; every unit := !dice do if unit = 5 then sum +:= 5
  206.         players[name][5] := sum
  207.         }
  208.     6 : {                        # sixes
  209.         sum := 0 ; every unit := !dice do if unit = 6 then sum +:= 6
  210.         players[name][6] := sum
  211.         }
  212.     7 : {                        # 3 of a kind
  213.         sum := 0 ; flag := 0
  214.         tmp := table(0) ; every unit := !dice do tmp[unit] +:= 1
  215.         every piece := key(tmp) do
  216.           if tmp[piece] >= 3 then flag := 1
  217.         if flag = 1 then every sum +:= !dice
  218.         players[name][7] := sum
  219.         }
  220.     8 : {                        # four of a kind
  221.         sum := 0 ; flag := 0
  222.         tmp := table(0) ; every unit := !dice do tmp[unit] +:= 1
  223.         every piece := key(tmp) do
  224.           if tmp[piece] >= 4 then flag := 1
  225.         if flag = 1 then every sum +:= !dice
  226.         players[name][8] := sum
  227.         }
  228.     9 : {                        # full house
  229.         sum := 0 ; flag := 0
  230.         tmp := table(0) ; every unit := !dice do tmp[unit] +:= 1
  231.         every piece := key(tmp) do
  232.           {
  233.           if tmp[piece] = 3 then flag +:= 1
  234.           if tmp[piece] = 2 then flag +:= 1
  235.           }
  236.         if flag = 2 then sum := 25
  237.         players[name][9] := sum
  238.         }
  239.    10 : {                        # small straight
  240.         sum  := 0 ; flag := 0
  241.         hold := set() ; every insert(hold,!dice)
  242.         tmp  := sort(hold)
  243.         if tmp[1]+1 = tmp[2] &
  244.            tmp[2]+1 = tmp[3] &
  245.            tmp[3]+1 = tmp[4] then flag := 1
  246.         if tmp[2]+1 = tmp[3] &
  247.            tmp[3]+1 = tmp[4] &
  248.            tmp[4]+1 = tmp[5] then flag := 1
  249.         if flag = 1 then sum := 30
  250.         players[name][10] := sum
  251.         }
  252.    11 : {                        # large straight
  253.         sum := 0 ; flag := 0  
  254.         tmp := sort(dice)
  255.         if tmp[1]+1 = tmp[2] &
  256.            tmp[2]+1 = tmp[3] &
  257.            tmp[3]+1 = tmp[4] &
  258.            tmp[4]+1 = tmp[5] then flag := 1
  259.         if flag = 1 then sum := 40
  260.         players[name][11] := sum
  261.         }
  262.    12 : {                        # yahtzee
  263.         sum := 0 ; flag := 0
  264.         tmp := table(0) ; every unit := !dice do tmp[unit] +:= 1
  265.         every piece := key(tmp) do
  266.           if tmp[piece] = 5 then flag := 1
  267.         if flag = 1 then sum := 50
  268.         players[name][12] := sum
  269.         }
  270.    13 : {                        # chance
  271.         sum := 0 ; every sum +:= !dice
  272.         players[name][13] := sum
  273.         }
  274.     }
  275.   end
  276.  
  277. #
  278. # THIS ROUTINE OBTAINS A VALID SHAKER REQUEST
  279. #
  280. procedure obtain(prompt)
  281.   local line, unit, units
  282.  
  283.   repeat
  284.     {
  285.     writes(at(1,22),prompt)
  286.     (line := read()) | next
  287.     if match("q",map(line)) then stop("Game Quit")
  288.     if trim(line) == "" then return []
  289.     units := parse(line,', \t')
  290.     every unit := !units do
  291.       (1 <= unit <= 5) | next
  292.     break
  293.     }
  294.   return units
  295.   end
  296.  
  297. #
  298. # THIS ROUTINE PAINTS THE SCORECARD FOR A GIVEN PLAYER
  299. #
  300. procedure score(name)
  301.   local st1, st2, i, bonus
  302.  
  303.   # Slight realignment.  -RLG
  304.   writes(at(1,11),chop(),at(18,11),under(),"Player = ",name,"     Round = ",under(round))
  305.   writes(at(10,12)," 1 : Ones    = ",players[name][1])
  306.   writes(at(10,13)," 2 : Twos    = ",players[name][2])
  307.   writes(at(10,14)," 3 : Threes  = ",players[name][3])
  308.   writes(at(10,15)," 4 : Fours   = ",players[name][4])
  309.   writes(at(10,16)," 5 : Fives   = ",players[name][5])
  310.   writes(at(10,17)," 6 : Sixes   = ",players[name][6])
  311.   writes(at(40,12)," 7 : 3oK     = ",players[name][7])
  312.   writes(at(40,13)," 8 : 4oK     = ",players[name][8])
  313.   writes(at(40,14)," 9 : FullH   = ",players[name][9])
  314.   writes(at(40,15),"10 : SmStr   = ",players[name][10])
  315.   writes(at(40,16),"11 : LgStr   = ",players[name][11])
  316.   writes(at(40,17),"12 : Yahtzee = ",players[name][12])
  317.   writes(at(40,18),"13 : Chance  = ",players[name][13])
  318.   st1 := 0 ; every i := 1 to 6 do st1 +:= numeric(players[name][i])
  319.   if st1 > 62 then bonus := 35 else bonus := 0
  320.   st2 := 0 ; every i := 7 to 13 do st2 +:= numeric(players[name][i])
  321.   writes(at(10,19),"Bonus = ",clip(bonus))
  322.   writes(at(10,20),"Subtotal = ",st1+bonus)
  323.   writes(at(40,20),"Subtotal = ",st2)
  324.   writes(at(37,21),"Grand Total = ",st1+st2+bonus)
  325.   end
  326.  
  327. #
  328. # From here down, all CT's VT-specific I/O codes have been replaced
  329. # with calls to iolib/itlib routines.  The replacements were quite
  330. # easy to do because of the great modularity of the original program.
  331. # -RLG
  332. #
  333.  
  334. #
  335. # VIDEO ROUTINE CLEARS SCREEN
  336. #
  337. procedure cls(str)
  338.   static clear_string
  339.   initial {
  340.     clear_string := getval("cl") |
  341.     (igoto(getval("cm"),1,1) || getval("cd")) |
  342.     stop("abort:  Your terminal can't clear screen!")
  343.     }
  344.   /str := ""
  345.   return clear_string || str
  346.   end
  347.  
  348. #
  349. # VIDEO ROUTINE ERASES REST OF SCREEN
  350. #
  351. procedure chop(str)
  352.   static clear_rest
  353.   initial {
  354.     clear_rest := getval("cd") |
  355.     stop("abort:  Sorry, your terminal must have cd capability.")
  356.   }
  357.   /str := ""
  358.   return clear_rest || str
  359.   end
  360.  
  361. #
  362. # VIDEO ROUTINE OUTPUTS UPPER HALF OF DOUBLE SIZE MESSAGES
  363. #
  364. procedure uhalf(str)
  365.   # Disabled for non-VT{2,3,4}XX terminals.  I'd have left them in for
  366.   # vt100s, but there are so many vt100 terminal emulation programs out
  367.   # there that don't do the big characters that I thought better of it.
  368.   # -RLG
  369.   static isVT
  370.   initial
  371.     {
  372.     if map(getname()) ? (tab(find("vt")+2), tab(any('234')), integer(tab(0)))
  373.     then isVT := 1
  374.     }
  375.   if \isVT then
  376.     {
  377.     /str := ""
  378.     if str == "" then return "\e#3"
  379.     return "\e#3" || str
  380.     }
  381.   end
  382.   
  383. #
  384. # VIDEO ROUTINE OUTPUTS BOTTOM HALF OF DOUBLE SIZE MESSAGES
  385. #
  386. procedure lhalf(str)
  387.   static isVT
  388.   initial
  389.     {
  390.     if map(getname()) ? (tab(find("vt")+2), tab(any('234')), integer(tab(0)))
  391.     then isVT := 1
  392.     }
  393.   if \isVT then
  394.     {
  395.     /str := ""
  396.     if str == "" then return "\e#4"
  397.     return "\e#4" || str
  398.     }
  399.   end
  400.  
  401. #
  402. # VIDEO ROUTINE OUTPUTS STRING AND CLEARS TO EOL
  403. #
  404. procedure clip(str)
  405.   static clear_line
  406.   initial
  407.     {
  408.     clear_line := getval("ce") | "                "
  409.     }
  410.   /str := ""
  411.   if str == "" then return clear_line
  412.   return str ||:= clear_line
  413.   end
  414.   
  415. #
  416. # VIDEO ROUTINE OUTPUTS HIGHLIGHTED STRINGS
  417. #
  418. procedure high(str)
  419.   static bold_code, off_other_modes
  420.   initial
  421.     {
  422.     off_other_modes := ""
  423.     every off_other_modes ||:= getval("me"|"ue"|"se")
  424.     bold_code := off_other_modes || getval("md"|"us"|"so")
  425.     }
  426.   /str := ""
  427.   return bold_code || str || off_other_modes
  428.   end
  429.  
  430. #
  431. # VIDEO ROUTINE OUTPUTS INVERSE VIDEO STRINGS
  432. #
  433. procedure inverse(str)
  434.   static reverse_code, off_other_modes
  435.   initial
  436.     {
  437.     off_other_modes := ""
  438.     every off_other_modes ||:= getval("se"|"ue"|"me")
  439.     reverse_code := off_other_modes || getval("so"|"us"|"md")
  440.     }
  441.   /str := ""
  442.   return reverse_code || str || off_other_modes
  443.   end
  444.  
  445. #
  446. # VIDEO ROUTINE OUTPUTS UNDERLINED STRINGS
  447. #
  448. procedure under(str)
  449.   static underline_code, off_other_modes
  450.   initial
  451.     {
  452.     off_other_modes := ""
  453.     every off_other_modes ||:= getval("ue"|"me"|"se")
  454.     underline_code := off_other_modes || getval("us"|"md"|"so")
  455.     }
  456.   /str := ""
  457.   return underline_code || str || off_other_modes
  458.   end
  459.  
  460. #
  461. # VIDEO ROUTINE OUTPUTS BLINKING STRINGS
  462. #
  463. procedure blink(str)
  464.   static blink_code, off_other_modes
  465.   initial
  466.     {
  467.     off_other_modes := ""
  468.     every off_other_modes ||:= getval("me"|"se"|"ue")
  469.     blink_code := off_other_modes || getval("mb"|"md"|"so"|"us")
  470.     }
  471.   /str := ""
  472.   return blink_code || str || off_other_modes
  473.   end
  474.  
  475. #
  476. # VIDEO ROUTINE SETS NORMAL VIDEO MODE
  477. #
  478. procedure norm(str)
  479.   static off_modes
  480.   initial
  481.     {
  482.     off_modes := ""
  483.     every off_modes ||:= getval("me"|"se"|"ue")
  484.     }
  485.   /str := ""
  486.   return off_modes || str
  487.   end
  488.  
  489. #
  490. # VIDEO ROUTINE TURNS ON VT GRAPHICS CHARACTERS
  491. #
  492. procedure graf(str)
  493.   # Again, disabled for non-VT{234}XX terminals.  -RLG
  494.   static isVT
  495.   initial
  496.     {
  497.     if map(getname()) ? (tab(find("vt")+2), tab(any('234')), integer(tab(0)))
  498.     then isVT := 1
  499.     }
  500.   /str := ""
  501.   if \isVT then
  502.     {
  503.     if str == "" then return "\e(0"
  504.     str := "\e(0" || str
  505.     if (str[-3:0] == "\e(B")
  506.       then return str
  507.       else return str || "\e(B"
  508.     }
  509.   else return str
  510.   end
  511.  
  512. #
  513. # VIDEO ROUTINE TURNS OFF VT GRAPHICS CHARACTERS
  514. #
  515. procedure nograf(str)
  516.   static isVT
  517.   initial
  518.     {
  519.     if map(getname()) ? (tab(find("vt")+2), tab(any('234')), integer(tab(0)))
  520.     then isVT := 1
  521.     }
  522.   /str := ""
  523.   if \isVT then
  524.     {
  525.     if str == "" then return "\e(B"
  526.     str := "\e(B" || str
  527.     }
  528.   return str
  529.   end
  530.  
  531. #
  532. # VIDEO ROUTINE SETS CURSOR TO GIVEN X,Y COORDINATES
  533. #
  534. procedure at(x,y) 
  535.   return igoto(getval("cm"), x, y)  
  536.   end
  537.  
  538. #########  Here end the I/O routines I needed to alter.  -RLG
  539.  
  540. #
  541. # PARSES A STRING INTO A LIST WITH RESPECT TO A GIVEN DELIMITER
  542. #
  543. procedure parse(line,delims)
  544.   local i, tokens
  545.   static chars
  546.   chars  := &cset -- delims
  547.   tokens := []
  548.   line ? while tab(upto(chars)) do put(tokens,tab(many(chars)))
  549.   #
  550.   # My first time playing, I didn't put spaces between the numbers
  551.   # for the dice.  When you think about it, though, why bother?
  552.   # They can't be any longer than one digit each, so there's no
  553.   # ambiguity.  This bit of code makes the game a bit more idiot-
  554.   # proof.  -RLG (one of the idiots)
  555.   #
  556.   if *!tokens > 1 then line ?
  557.     {
  558.     tokens := []
  559.     if tab(upto(&digits)) then
  560.       {
  561.       while put(tokens, move(1)) do
  562.         tab(upto(&digits)) | break
  563.       put(tokens, integer(tab(0)))
  564.       }
  565.     }
  566.   return tokens
  567.   end
  568.  
  569. #
  570. # TAKE AN INPUT STRING VIA GIVEN PROMPT
  571. #
  572. procedure input(prompt)       
  573.   writes(prompt)
  574.   return read()
  575.   end
  576.