home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / VSNBL220.ZIP / RPOEM.SNO < prev    next >
Encoding:
Text File  |  1991-02-14  |  6.6 KB  |  198 lines
  1. *    RPOEM.SNO - Poetry Generator
  2. *
  3. *    Reads "grammar" from file RPOEM.DAT and generates "poetry."
  4. *
  5. *    The grammar contains syntactic variables, each of which is
  6. *    is provided with multiple alternatives.  A random number
  7. *    generator is used to select among the alternatives.
  8. *    Most alternatives are literal strings; some are syntactic
  9. *    variables, causing a recursion.
  10. *
  11. *    RPOEM and RSELECT are several of the many programs and functions
  12. *    from "Algorithms in SNOBOL4," by James F. Gimpel.  They have been
  13. *    simplified and altered for use with Vanilla SNOBOL4.
  14. *
  15. *    V1.1 Improve seed selection for random number generator.
  16. *
  17. *    (c) Copyright 1987 Catspaw, Inc.
  18.  
  19.  
  20.     &TRIM   = 1
  21.     &ANCHOR = 1
  22.  
  23. * Open the grammar file
  24. *
  25.     INPUT(.IN_FILE,1,,'RPOEM.DAT')        :S(START)
  26.     OUTPUT = "Could not open grammar file - RPOEM.DAT"    :(END)
  27. START
  28.  
  29. -EJECT
  30. * RANDOM(N)
  31. *    Returns a random number in the range 1 to N.
  32. *    This function has a period of only 490, which is adequate for
  33. *    a poetry generator, but not for serious mathematical work.
  34. *    A far better generator can be constructed with the 64-bit real
  35. *    numbers of SNOBOL4+.
  36. *
  37.     DEFINE('RANDOM(N)')
  38.     RAN_VAR = 1                :(RANDOM_END)
  39. RANDOM    RAN_VAR = REMDR(RAN_VAR * 59, 491)
  40.     RANDOM  = ((N * RAN_VAR) / 491) + 1    :(RETURN)
  41. RANDOM_END
  42.  
  43. -EJECT
  44. * RSELECT(S)
  45. *    Select a random alternative from S.
  46. *
  47. *    S is of the form "|ABC|CAT|...|HOTDOG", where the first character
  48. *    is the delimiter between alternatives, and there may be an
  49. *    arbitrary number of alternatives.
  50. *
  51. *    Since RSELECT will be called repeatedly with the same argument
  52. *    string, a major optimization occurs here.  A table called CODE
  53. *    is created, and the alternatives are stored within it.  After
  54. *    breaking out all the alternatives, the table is converted to
  55. *    an array with a unique name, RSEL.n, where n is incremented for
  56. *    each different S the function is called with.
  57. *
  58. *    Then a line of code is constructed of the form:
  59. *        " RESELECT = RSEL.n<RANDOM(w), 2> :(RETURN)"
  60. *    where w is the number of alternatives.  Thus, executing this code
  61. *    fragment will return a string chosen at random from the array RSEL.n.
  62. *    The code is compiled and saved in a master table, RSEL_TBL, indexed
  63. *    by the original string S.
  64. *
  65. *    On subsequent calls, the function consults RSEL_TBL.  If the argument
  66. *    string is found, the table provides the ALREADY COMPILED CODE, and
  67. *    merely jumps to it to pick an alternative.  If it is not found in
  68. *    the table, then the previous code construction process is begun.
  69. *
  70. *    This is an interesting function because it illustrates that table
  71. *    entries can contain compiled code, not just strings, and shows the
  72. *    use of the indirection operator ($) to construct new variable names.
  73. *
  74.  
  75.     DEFINE('RSELECT(S)WTS,ALT,CODE,SSAVED,BC')
  76. *
  77. *    Initialization. Define master table, and counter for the sub-arrays.
  78. *
  79.     RSEL_TBL  =  TABLE()
  80.     RSEL_CTR  =  0                :(RSELECT_END)
  81. *
  82. *    Function entry.  Test if argument has been seen before.
  83. *    If so, simply jump to the compiled code and return to caller from it.
  84. *
  85. RSELECT    CODE = RSEL_TBL<S>
  86.     DIFFER(CODE,NULL)            :S<CODE>
  87. *
  88. *    New argument.  Have to parse it.  Save copy and obtain delimiter.
  89.     SSAVED  =  S
  90.     S   LEN(1) . BC  =            :F(RETURN)
  91. *
  92. *    Create pattern to isolate alternatives, and table to save them.
  93.     RSEL_PAT = (BREAK(BC) | REM) . ALT
  94.     CODE = TABLE()
  95. *
  96. *    Loop removing alternatives and storing them in table CODE.
  97. RSELECT_1
  98.     S   RSEL_PAT  =                :F(ERROR)
  99.     WTS  =  WTS + 1
  100.     CODE<WTS> =  ALT
  101.     S   BC  =                :S(RSELECT_1)
  102. *
  103. *    Convert table to array with unique name.  Since CONVERT
  104. *    creates a 2-dimensional array, there is some wastage here,
  105. *    as we are only using the second column.
  106.     RSEL_CTR = RSEL_CTR + 1
  107.     $('RSEL.' RSEL_CTR) = CONVERT(CODE,"ARRAY")
  108. *
  109. *    Build the code string to randomly select an element of the
  110. *    array, and return to caller.
  111.     CODE  =  ' RSELECT = RSEL.' RSEL_CTR '<RANDOM(' WTS '),2>'
  112. +        ' :(RETURN)'
  113.     S  =  SSAVED
  114. *
  115. *    Compile the code, save it in master table, and restart function.
  116.     RSEL_TBL<S>  =  CODE(CODE)        :S(RSELECT)F(ERROR)
  117. RSELECT_END
  118.  
  119. -EJECT
  120. * RSENTENCE(STACK)
  121. *    Generates a random sentence according to the grammar
  122. *    read from IN_FILE during initialization.
  123. *
  124. *    If the argument string contains any syntactic variables, they
  125. *    are expanded according to the grammar.
  126. *
  127. *    Grammar meta-language:
  128. *    <name>::=alternative1|alt2|alt3|...|altn
  129. *
  130. *    Continuation lines begin with a blank in column 1.
  131. *    Alternatives may be strings, other <name>'s, or one of the following:
  132. *        =name=    is like <name>, but also assigns the result of its
  133. *            expansion to the SNOBOL4 variable $name.
  134. *        (name)    produces EVAL(name).
  135. *    END in column 1 terminates the grammar.
  136. *
  137. *    See "Algorithms in SNOBOL4," pp. 354-359 for a complete description.
  138. *
  139.     DEFINE('RSENTENCE(STACK)VAR,EXP,S,TEXT')
  140. *
  141. *    Initialization.  Define patterns and table to hold rules from file.
  142.     SYN.VAR      =  '<'  ARB . VAR  '>'
  143.     SNOBAL.EXP   =  '(' ARB . EXP ')'
  144.     ASGN.VAR     =  '='  ARB . VAR  '='
  145.     LITERAL.TEXT =  BREAK('<=(') . TEXT
  146.     RSENT_TBL    =  TABLE()
  147. *
  148. *    Read file.  Concatenate continuation lines.
  149.     SS  =  IN_FILE
  150. RSI_1    S   =  IN_FILE
  151.     S    ('<' | 'END' RPOS(0))        :S(RSI_2)
  152.     SS  =  SS S                :(RSI_1)
  153. *
  154. *    Here with a complete rule (or "END").  Get name and save rule.
  155. RSI_2    SS   '<' ARB . NM '>::='  =
  156.     RSENT_TBL<NM>  =  '|'  SS
  157.     IDENT(S,'END')                :S(RSENTENCE_END)
  158.     SS  =  S                :(RSI_1)
  159. *
  160. *    Entry point.  If argument begins with <var>, obtain alternatives
  161. *    string from RSENT_TBL, and use RSELECT to it with an alternative.
  162. RSENTENCE
  163.     STACK SYN.VAR = RSELECT(RSENT_TBL<VAR>)    :S(RSENTENCE)
  164. *
  165. *    If arg begins with (exp), just EVAL it and add it to output S.
  166.     STACK   SNOBAL.EXP  =            :F(RSENT_1)
  167.     S  =  S  EVAL(EXP)            :(RSENTENCE)
  168. *
  169. *    If arg begins with =var=, treat like <var>, but save in $var.
  170. RSENT_1    STACK  ASGN.VAR  =            :F(RSENT_2)
  171.     $VAR  =  RSENTENCE('<' VAR '>')
  172.     S  =  S  $VAR                :(RSENTENCE)
  173. *
  174. *    Not <var>, (exp), or =var=, must be literal text.  If there is
  175. *    a syntactic variable beyond, remove text to S, and process variable.
  176. RSENT_2    STACK   LITERAL.TEXT  =            :F(RSENT_3)
  177.     S   =   S  TEXT                :(RSENTENCE)
  178. *
  179. *    Nothing beyond this text.  Just add it to S, and return result.
  180. RSENT_3    RSENTENCE  =  S  STACK            :(RETURN)
  181. RSENTENCE_END    SS =
  182.  
  183. -EJECT
  184. *******    MAIN PROGRAM *******
  185. *
  186. *    Seed the random number generator with seconds and minutes
  187. *     from real-time clock
  188.     DATE() LEN(12) LEN(2) . MINUTE LEN(1) LEN(2) . SECOND
  189.     RAN_VAR = REMDR(MINUTE * SECOND, 490) + 1
  190. *
  191. *    Expand the syntactic variable <RPOEM>.  Slash indicates end of line.
  192. LOOP    POEM = RSENTENCE('<RPOEM>')
  193. *
  194. *    Break into lines and display
  195. PRINT    POEM BREAK('/') . OUTPUT '/' =        :S(PRINT)
  196.     OUTPUT =                :(LOOP)
  197. END
  198.