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