PageRenderTime 26ms CodeModel.GetById 33ms RepoModel.GetById 0ms app.codeStats 0ms

/examples/casket/valentine-bingo.rx

https://github.com/crcx/retro-language
Forth | 84 lines | 65 code | 14 blank | 5 comment | 1 complexity | 5df6121c4e220003b439b68a105be0af MD5 | raw file
    

  1. ( Port of http://groups.google.com/group/comp.lang.forth/browse_frm/thread/f37aff28d9a3102e )
    2. 

  2. ( This is a pretty simple Bingo card generator using an array of words/phrases.             )
    3. 

  3. ( We start by setting up an array of strings, then randomly sort this into a secondary      )
    4. 

  4. ( array. The "free space" location is manually patched, and then the resulting array is     )
    5. 

  5. ( rendered as HTML.                                                                         )
    6. 

  6. 

  7. needs casket'
    8. 

  8. needs array'
    9. 

    10. 

  10. [ "Be Mine"
    11. 

  11.   "Love"
    12. 

  12.   "It's Love"
    13. 

  13.   "All Mine"
    14. 

  14.   "Kiss Me"
    15. 

  15.   "You & Me"
    16. 

  16.   "Awesome"
    17. 

  17.   "My Baby"
    18. 

  18.   "Love Me"
    19. 

  19.   "All Star"
    20. 

  20.   "My Way"
    21. 

  21.   "Love You"
    22. 

  22.   "For You"
    23. 

  23.   "Cool"
    24. 

  24.   "I Hope"
    25. 

  25.   "Love Life"
    26. 

  26.   "Angel"
    27. 

  27.   "Sweet Talk"
    28. 

  28.   "True Love"
    29. 

  29.   "Be Good"
    30. 

  30.   "How Nice"
    31. 

  31.   "Let's Kiss"
    32. 

  32.   "#1 Fan"
    33. 

  33.   "Be True"
    34. 

  34.   "Love Her" ] ^array'fromQuote constant WORDS
    35. 

    36. 

  36. WORDS ^array'length constant #WORDS
    37. 

    38. 

  38. create CARD
    39. 

  39.   #WORDS dup , allot
    40. 

  40. 

  41. : nth  ( na-$ )
    42. 

  42.   1+ + @ ;
    43. 

  43. 

  44. : rnd  ( -n )
    45. 

  45.   random #WORDS mod ;
    46. 

  46. 

  47. : obtain  ( -$ )
    48. 

  48.   0 [ drop rnd WORDS nth dup CARD ^array'stringIn? ] while ;
    49. 

    50. 

  50. : populate  ( - )
    51. 

  51.   CARD 1+ #WORDS [ obtain swap !+ ] times drop "Free Square" CARD 13 + ! ;
    52. 

  52. 

  53. : card  ( - )
    54. 

  54.   populate CARD 1+
    55. 

  55.   5 [ "<tr align='center'>" puts 5 [ @+ "<td>%s</td>" puts cr ] times "</td>" puts ] times cr ;
    56. 

  56. 

  57. : header  ( - )
    58. 

  58.   "\n<html>\n" puts
    59. 

  59.   "<body>\n" puts
    60. 

  60.   "<table border=1 height=500 width=500>\n" puts
    61. 

  61.   "<tr style='color: red'>\n" puts
    62. 

  62.   "<th width='20\%'>B</th>\n" puts
    63. 

  63.   "<th width='20\%'>I</th>\n" puts
    64. 

  64.   "<th width='20\%'>N</th>\n" puts
    65. 

  65.   "<th width='20\%'>G</th>\n" puts
    66. 

  66.   "<th width='20\%'>O</th>\n" puts
    67. 

  67.   "</tr>\n" puts ;
    68. 

  68. 

  69. : footer  ( - )
    70. 

  70.   "</table>\n" puts
    71. 

  71.   "</body>\n" puts
    72. 

  72.   "</html>\n" puts ;
    73. 

  73. 

  74. with casket'
    75. 

  75. : /bingo  ( - )
    76. 

  76.   Content-type: text/html
    77. 

  77.   header card footer ;
    78. 

  78. 

  79. [ ( -$ ) "/home/crc/apps/bingo/" ] is casket:root
    80. 

  80. [ ( -$ ) "http://rx-core.org/dev/bingo" ] is casket:url
    81. 

  81. &/bingo is /
    82. 

  82. &dispatch is boot
    83. 

  83. save bye
    84. 

  84. 

  85.