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 / gprocs / drawcard.icn < prev    next >
Text File  |  2000-07-29  |  6KB  |  195 lines
  1. ############################################################################
  2. #
  3. #    File:     drawcard.icn
  4. #
  5. #    Subject:  Procedure to draw a playing card
  6. #
  7. #    Author:   Gregg M. Townsend
  8. #
  9. #    Date:     June 23, 2000
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #     drawcard(win, x, y, c) draws the playing card labeled <c> with its
  18. #  upper left corner at (x,y).  The card size is fixed at 80w x 124h.
  19. #
  20. #     Card labelings are those used in the examples in the "Mappings and
  21. #  Labelings" chapter of the Icon book (pp 205-207, 2/e).
  22. #
  23. #         label: ABCDEFGHIJKLM NOPQRSTUVWXYZ abcdefghijklm nopqrstuvwxyz
  24. #         rank:  A23456789TJQK A23456789TJQK A23456789TJQK A23456789TJQK
  25. #         suit:  clubs........ diamonds..... hearts....... spades.......
  26. #
  27. #  If the label is unrecognized, the back of a card is drawn.
  28. #  "-" is suggested as a conventional label for a card back.
  29. #
  30. ############################################################################
  31. #
  32. #  Requires:  Version 9 graphics
  33. #
  34. ############################################################################
  35. #
  36. #  Links:  cardbits, graphics
  37. #
  38. ############################################################################
  39.  
  40. link cardbits
  41. link graphics
  42.  
  43. procedure drawcard(win, x, y, label)
  44.    static cmap, gc, bk, plist, deck
  45.    local ysuit, yrank, r, s, i, l, dx, dy
  46.  
  47.    if type(win) ~== "window" then {
  48.       win :=: x :=: y :=: label
  49.       win := &window
  50.       }
  51.    if /gc then {
  52.       # funny order of card deck is for conversion to ranks below
  53.       deck := "ABCDEFGHIJKLMnopqrstuvwxyzabcdefghijklmNOPQRSTUVWXYZ"
  54.       cmap := cardmap() | stop("can't initialize card fragments")
  55.       gc := Clone(win, "fg=black", "bg=white")
  56.       bk := Clone(gc)
  57.       Pattern(bk, "32,#_
  58.          04444044_
  59.          0A08000A_
  60.          11101011_
  61.          0A00080A_
  62.          44004404_
  63.          8000A000_
  64.          10011001_
  65.          A0002000_
  66.          40044404_
  67.          000A0A02_
  68.          01111101_
  69.          020A0A00_
  70.          44440440_
  71.          00A00020_
  72.          11100111_
  73.          008000A0_
  74.          40440444_
  75.          000A0A08_
  76.          10111110_
  77.          080A0A00_
  78.          44044400_
  79.          A0008000_
  80.          10011001_
  81.          2000A000_
  82.          44044004_
  83.          0A02000A_
  84.          11010111_
  85.          0A00020A_
  86.          04404444_
  87.          002000A0_
  88.          01111110_
  89.          00A00080")
  90.       WAttrib(bk, "fillstyle=textured")
  91.       if WAttrib(bk, "depth") > 1 then
  92.          WAttrib(bk, "fg=dark red-yellow", "bg=light red-yellow")
  93.       plist := [
  94.          [0, 0],            #  A
  95.          [0, 39],            #  2
  96.          [0, 39, 0, 0],            #  3
  97.          [16, 39],            #  4
  98.          [16, 39, 0, 0],        #  5
  99.          [16, 0, 16, 39],        #  6
  100.          [16, 0, 16, 39, 0, -20],    #  7
  101.          [16, 0, 16, 39, 0, 20],    #  8
  102.          [16, 13, 16, 39, 0, 0],    #  9
  103.          [16, 13, 16, 39, 0, 26]    # 10
  104.          ]
  105.       }
  106.  
  107.    if (i := (deck ? find(label)) - 1) then {
  108.       r := i % 13 + 1            # 1 to 13 for A,2,...,9,10,J,Q,K
  109.       s := i / 13 + 1            # 1=heart, 2=diamond, 3=spade, 4=club
  110.       }
  111.    else {
  112.       # unrecognized; draw card back
  113.       DrawRectangle(gc, x, y, 80-1, 124-1)
  114.       FillRectangle(bk, x+1, y+1, 80-2, 124-2)
  115.       return
  116.       }
  117.  
  118.    ClearOutline(gc, x, y, 80-1, 124-1)
  119.    ysuit := 94 * (s-1)
  120.    yrank := (if s <= 2 then 404 else 376)
  121.  
  122.    CopyArea(cmap, gc, 9 * (r-1), yrank, 9, 14, x+4, y+6)    # rank
  123.    CopyArea(cmap, gc, 9 * (r-1), yrank+14, 9, 14, x+67, y+104)    # inverted rank
  124.    CopyArea(cmap, gc, 148, ysuit+40, 9, 14, x+4, y+22)        # suit
  125.    CopyArea(cmap, gc, 148, ysuit+54, 9, 14, x+67, y+88)    # inverted suit
  126.  
  127.    if r > 10 then
  128.       CopyArea(cmap, gc, 48 * (r-11), ysuit, 48, 94, x+16, y+15) # faces
  129.    else if (r = 1) & (s = 4) then
  130.       CopyArea(cmap, gc, 117, 376, 43, 56, x+18, y+34)        # ace of spaces
  131.    else {
  132.       l := plist[r]
  133.       i := 0
  134.       while (dx := l[i +:= 1]) & (dy := l[i +:= 1]) do {
  135.          if dy = 0 then {
  136.             # pip in center row; reflect horizontally if dx positive
  137.             CopyArea(cmap, gc, 144, ysuit, 16, 20, x + dx + 32, y + 52)
  138.             if dx > 0 then
  139.                CopyArea(cmap, gc, 144, ysuit, 16, 20, x - dx + 32, y + 52)
  140.             }
  141.          else if dx = 0 then {
  142.             # pip in center column; reflect vertically if dy positive
  143.             if dy > 0 then {
  144.                CopyArea(cmap, gc, 144, ysuit + 20, 16, 20, x + 32, y + dy + 52)
  145.                CopyArea(cmap, gc, 144, ysuit, 16, 20, x + 32, y - dy + 52)
  146.                }
  147.             else
  148.                CopyArea(cmap, gc, 144, ysuit, 16, 20, x + 32, y + dy + 52)
  149.             }
  150.          else {
  151.             # all other positions are 4-way symmetric
  152.             CopyArea(cmap, gc, 144, ysuit+20, 16, 20, x + dx + 32, y + dy + 52)
  153.             CopyArea(cmap, gc, 144, ysuit+20, 16, 20, x - dx + 32, y + dy + 52)
  154.             CopyArea(cmap, gc, 144, ysuit, 16, 20, x + dx + 32, y - dy + 52)
  155.             CopyArea(cmap, gc, 144, ysuit, 16, 20, x - dx + 32, y - dy + 52)
  156.             }
  157.          }
  158.       }
  159.    return
  160. end
  161.  
  162. #  cardmap() -- create and load card bitmap
  163. #
  164. #  The bitmap is in a separate source file cardbits.icn due to its size.
  165. #  It is represented there as a bilevel image.
  166.  
  167. procedure cardmap()        # create and load card bitmap
  168.    local ims, cmap, rmap
  169.  
  170.    ims := cardbits()
  171.    cmap := open("cardbits", "g", "canvas=hidden", "size=160,432") | fail
  172.                         # make offscreen canvas
  173.    DrawImage(cmap, 0, 0, cardbits())         # load card fragments
  174.  
  175.    if WAttrib(cmap, "depth") == "1" then {    # if monochrome screen
  176.       # dither red portions
  177.       Pattern(cmap, "4,#4141")
  178.       WAttrib(cmap, "fillstyle=masked", "fg=white")
  179.       FillRectangle(cmap, 0, 0, 160, 188, 0, 404, 117, 128)
  180.       # redraw face outlines
  181.       WAttrib(cmap, "fillstyle=solid", "fg=black")
  182.       every DrawRectangle(cmap, 0 to 96 by 48, 0 to 282 by 94, 47, 93)
  183.       }
  184.    else {                    # if color screen
  185.       # replace red portions with red bitmaps
  186.       rmap := open("redcards", "g", "canvas=hidden", "size=160,432",
  187.          "fg=dark red") | fail
  188.       DrawImage(rmap, 0, 0, cardbits())
  189.       CopyArea(rmap, cmap, 0, 0, 160, 188, 0, 0)
  190.       CopyArea(rmap, cmap, 0, 404, 117, 128, 0, 404)
  191.       Uncouple(rmap)
  192.       }
  193.    return cmap                    # return pixmap
  194. end
  195.