1  
   2  public class Cons<T,U>
   3  {
   4      private T car;
   5      private U cdr;
   6  
   7      public Cons( T carArg, U cdrArg )
   8      {
   9          car = carArg;
  10          cdr = cdrArg;
  11      }
  12  
  13      public T getCar(){ return car; }
  14      public U getCdr(){ return cdr; }
  15  }

   1  
   2  
   3  ;; 
   4  ;;(pairlis '(1 2 3) '("one" "two" "three") '((4 "four"))) 
   5  ;;
   6  
   7   
   8  (define (pairlis keys data alist) 
   9    (setq data2 data) 
  10    (setq newlist '()) 
  11    (dolist (x keys) 
  12            (push (list x (pop data2)) newlist -1)) 
  13    (append newlist alist)) 
  14  
  15  ;; newLISPy way
  16  
  17  (define (pairlis keys data alist) 
  18    (append (map (lambda (x y) (list x y)) keys data) alist)) 
  19  
  20  

   1  
   2  ;; (amazon-op "Operation=ItemSearch&SearchIndex=Books&ItemPage=1&Keywords=Cloud+Atlas&Respon\
   3  seGroup=Request,Small")
   4  ;;
   5  ;; (amazon-op "Operation=SimilarityLookup&ItemId=1400063795,0812966929&SimilarityType=Random\
   6  &ResponseGroup=Request,Large")
   7  ;; (amazon-op "Operation=SimilarityLookup&ItemId=1400063795,061873516X,0812966929&Similarity\
   8  Type=Random&ResponseGroup=Request,Small")
   9  
  10  ;;  (setq x (xml-digest (amazon-op "Operation=ItemLookup&ItemId=0375507256&ResponseGroup=Req\
  11  uest,Similarities,ListmaniaLists")))
  12  ;; Using x get a list of listmanias for an item
  13  ;;  (map (lambda (x) (x 1 2 2)) (1 -1 (x (chop (ref 'ListmaniaLists  x)))))
  14  
  15  ;; (setq y (amazon-op "Operation=ListLookup&ListType=Listmania&ListId=R21LV6VJEZ794O&Respons\
  16  eGroup=ListFull"))
  17  ;; Using y get a list of ISBNs from a listmania
  18  ;; (map (lambda(x) (x 4 1 2 )) (8 -1 ( (y (chop (ref 'Lists y)) ) 2))) ; gives list of ISBNs\
  19   from the listmania
  20  
  21  ;; get a list of listmania details from a list of listmanias.
  22  ;;  (setq z   (map (lambda (x) (xml-digest (amazon-op (append "Operation=ListLookup&ListType\
  23  =Listmania&ListId=" x "&ResponseGroup=ListFull"))))  (map (lambda (x) (x 1 2 2)) (1 -1 (x (c\
  24  hop (ref 'ListmaniaLists  x))))))  )
  25  ;;
  26  ;; get a list of ISBNs from all of the listmanias for the item
  27  ;; (setq z (flat (map (lambda(y) (map (lambda(x) (x 4 1 2 )) (8 -1 ( (y (chop (ref 'Lists y)\
  28  ) ) 2))) ) z)))
  29  ;;
  30  
  31  ;; get item info for all the ISBNs from all listmanias related to the original item
  32  ;; (setq w (map (lambda (x) (xml-digest (amazon-op (append "Operation=ItemLookup&ItemId=" x)\
  33  )))  (unique z)))
  34  
  35  ;; get a list of pair (title,author) from w above.
  36  ;; (map (lambda (x) (list ((x (chop (ref 'Title x))) 1)  (if (ref 'Author x)((x (chop (ref '\
  37  Author x)))1) "???"))) w)
  38  
  39  (define (amazon-op params)
  40    (get-url (append 
  41  "http://webservices.amazon.com/onca/xml?Service=AWSECommerceService&&AWSAccessKeyId=YOUROWNKEY&" params)))
  42  
  43  (define (xml-digest result)
  44    (xml-type-tags nil nil nil nil)
  45    (setq xresult (xml-parse result (+ 1 2 4 8 16))))
  46  

   1  
   2  (define (x x) (x x))
   3  
   4  (x x)
   5  
   6  ;; Or
   7  
   8  ((lambda (x) (x x)) (lambda (x) (x x)))

   1  
   2  ;; combine APIs and other web available bibliographic data.
   3  ;; Use amazon, LibraryThing, and OCLC Worldcat.
   4  ;; Get ISBN numbers for a book by searching author and title.
   5  ;; Get the list of available ISBNs from different sources.
   6  ;; Get "tags" available for a book from LibraryThing for
   7  ;; a given book.
   8  ;; etc.
   9  ;;
  10  ;; N.B. A person from LibraryThing.com posted a comment
  11  ;; regarding this program, indicating that the tag cloud data
  12  ;; is copyrighted. 
  13  ;;
  14  ;; Here's the quoted message:
  15  ;;
  16  ;; Tim's message: "And it's fine here, as a test, and probably in other 
  17  ;; contexts where it could be considered "fair use" under copyright. 
  18  ;; But--unlike the thingISBN service and some other LibraryThing 
  19  ;; APIs--LibraryThing's tag clouds are not free for public use, 
  20  ;; outside of the RSS feeds and widgets we provide. 
  21  ;; We're not sure how and under what license to 
  22  ;; release them when we do."
  23  ;;
  24  ;; So, I wrote this for fun.  If I were you I wouldn't run it, just read
  25  ;; the code.  :-)
  26  ;;
  27  
  28  
  29  (define (search-worldcat title author)
  30    (setq title (replace " " title "+"))
  31    (setq author (replace " " author "+"))
  32    (get-url (append "http://worldcatlibraries.org/search?q=ti:" title "+au:" author "&qt=advanced")))
  33  
  34  (setq oclc-url-1-pattern {<div class="name"><a href=})
  35  
  36  (define (oclc-url-1 str)
  37    (setq loc (find oclc-url-1-pattern str))
  38    (setq loc (+ loc (length oclc-url-1-pattern)))
  39    (setq loc (+ 1 loc))
  40    (setq loc-end (find ">" (loc -1 str)))
  41    (setq loc-end (- loc-end 1))
  42    (setq loc-url (loc loc-end str))
  43    (println (append "http://worldcatlibraries.org" loc-url))
  44    (get-url (append "http://worldcatlibraries.org" loc-url)))
  45  
  46  (setq oclc-isbn-pattern "<strong>ISBN: </strong>")
  47  
  48  (define (find-isbn str)
  49    (setq loc (find oclc-isbn-pattern str))
  50    (setq loc (+ loc (length oclc-isbn-pattern)))
  51    (setq loc-end (find "</li>" (loc -1 str)))
  52    (loc loc-end str))
  53  
  54  (define (thing-isbn isbn)
  55    (xml-type-tags nil nil nil nil)
  56    (setq isbn-data 
  57        (xml-parse (get-url  
  58            (append "http://www.librarything.com/api/thingISBN/" isbn)))))
  59  
  60  (define (get-isbn-list isbn-data)
  61    (setq indexer (ref "isbn" isbn-data))
  62    (nth-set 2 indexer 2)
  63    (setq num-isbns (length  (isbn-data 0)))
  64    (setq isbn-list '())
  65    (for (idx (first (1 indexer))  (- num-isbns 1))
  66          (push (isbn-data (first (0 indexer)) idx (first (2 indexer))) isbn-list -1))
  67     isbn-list)
  68  
  69  (define (add-explorer-path)
  70     (env "PATH" (append (env "PATH" ) ";c:\\program files\\internet explorer")))
  71  
  72  (define (show-amazon-isbn isbn)
  73     (process (append "iexplore " "http://www.amazon.com/exec/obidos/ASIN/"
  74             isbn )))
  75  
  76  
  77  (define (get-librarything-isbn isbn)
  78      (get-url (append "http://librarything.com/isbn/" isbn)))
  79  
  80  (define (get-librarything-tagsection str)
  81      (setq loc (find "Tags used" str ))
  82      (setq mystr (loc -1 str))
  83      (setq loc-end (find "</div>" mystr))
  84       (0 loc-end mystr))
  85  
  86  (define (get-librarything-taglist mystr)
  87      (setq tags-list '())
  88      (while (setq tag-loc (find "/tag/" mystr))
  89          (setq tag-loc-end (find "target=" (tag-loc -1 mystr)))
  90          (push ((+ tag-loc 5) (- tag-loc-end 7) mystr) tags-list -1)
  91          (setq mystr ((+ tag-loc tag-loc-end ) -1 mystr)))
  92      tags-list)
  93  
  94  (define (show-librarything-tag tag)
  95     (process (append "iexplore " "http://www.librarything.com/tag/"
  96             tag )))
  97  

   1  
   2  (define cons
   3   (lambda (u v)
   4     (lambda (b)
   5       (cond (b u)
   6       (#t v)))))
   7  (define lunch (cons 'apple '()))
   8  (define car (lambda (l) (l #t)))
   9  (define cdr (lambda (l) (l #f)))
  10  
  11  

   1  
   2  (define Y
   3    (lambda (f)
   4      (let ((future
   5              (lambda (future)
   6                (f (lambda (arg) 
   7                     ((future future) arg))))))
   8        (future future))))
   9  
  10  ((Y (lambda (factorial)
  11        (lambda (n)
  12          (if (= n 0)
  13              1
  14              (* n (factorial (- n 1)))))))
  15   42)

   1  
   2  ;; simple definition of factorial:
   3  ;; this will run into trouble due to precision
   4  
   5  (define (factorial-1  num)
   6    (if (= num 0)
   7        1
   8        (* num (factorial-1 (- num 1)))))
   9  
  10  ;; factorial using imported GMP package:
  11  ;; it works better but runs into trouble with too deep call stack
  12  
  13  (load "gmp.lsp")
  14  
  15  (define (factorial-gmp num)
  16    (if (= num 0)
  17        "1"
  18        (GMP:* (string num) (factorial-gmp (- num 1)))))
  19  
  20  ;; Finally, a trampoline style recursive definition of
  21  ;; factorial which simulates tail recursive implementation
  22  ;; avoiding call stack overflow
  23  
  24  (define (factorial-acc num acc)
  25    (if (= num 0)
  26        (land (string acc))
  27        (bounce factorial-acc (- num 1) (GMP:* (string num) (string acc)))))
  28  
  29  (define (factorial-trampoline num)
  30    (trampoline factorial-acc num 1))
  31  
  32  (define (trampoline func num acc)
  33    (set 'bouncer (bounce func num acc))
  34    (catch (while 1
  35  		(set 'bouncer (bouncer))
  36  		(if (not (lambda? bouncer))
  37  		    (throw bouncer)))))
  38  
  39  (define (bounce)
  40    (letex (func (args 0) num (args 1) acc (args 2))
  41  	(lambda() (func num acc))))
  42  
  43  (define (land val)  val)
  44  

   1  
   2  
   3  
   4  (define (F x y z)
   5    (| (& x y) (& (& 0xffffffff (~ x)) z)))
   6  
   7  (define (G x y z)
   8    (| (& x z) (& y (& 0xffffffff (~ z)))))
   9  
  10  (define (H x y z)
  11    (^ x y z))
  12  
  13  (define (I x y z)
  14    (^ y (| x (& 0xffffffff (~ z)))))
  15  
  16  (define (rotate-left x n)
  17    (| (& 0xffffffff (<< x n)) (& 0xffffffff (>> x (- 32 n)))))
  18  
  19  (define (FF a b c d x s ac)
  20    (set 'a (& 0xffffffff (+ a (F b c d) x ac)))
  21    (set 'a (rotate-left a s))
  22    (set 'a (& 0xffffffff (+ a b))))
  23  
  24  (define (GG a b c d x s ac)
  25    (set 'a (& 0xffffffff (+ a (G b c d) x ac)))
  26    (set 'a (rotate-left a s))
  27    (set 'a (& 0xffffffff (+ a b))))
  28  
  29  (define (HH a b c d x s ac)
  30    (set 'a (& 0xffffffff (+ a (H b c d) x ac)))
  31    (set 'a (rotate-left a s))
  32    (set 'a (& 0xffffffff (+ a b))))
  33  
  34  (define (II a b c d x s ac)
  35    (set 'a (& 0xffffffff (+ a (I b c d) x ac)))
  36    (set 'a (rotate-left a s))
  37    (set 'a (& 0xffffffff (+ a b))))
  38  
  39  (define (md5-init )
  40    (set 'md5-i '(0 0))
  41    (set 'md5-in (dup 0 64))
  42    (set 'md5-digest (dup 0 16))
  43    (set 'md5-buf '(0x67452301 0xefcdab89 0x98badcfe 0x10325476)))
  44  
  45  (define (md5-update inbuf inlen)
  46    ;; compute number of bytes mod 64
  47    (set 'mdi (& (>> (md5-i 0) 3) 0x3f))
  48  
  49    ;; update number of bits
  50    (if (< (+ (md5-i 0)  (<< inlen 3)) (md5-i 0))
  51        (nth-set (md5-i 1) (+ 1 (md5-i 1))))
  52  
  53    (nth-set (md5-i 0) (+ (md5-i 0) (<< inlen 3)))
  54    (nth-set (md5-i 1) (+ (md5-i 1) (>> inlen 29)))
  55  
  56    (set 'inbuf-index 0)
  57    (while (> inlen 0)
  58  	 ;; add new character to buffer, increment mdi
  59  	 (nth-set (md5-in mdi) (inbuf inbuf-index))
  60  	 (set 'mdi (+ mdi 1))
  61  	 (set 'inbuf-index (+ inbuf-index 1))
  62  
  63  	 ;; transform if necessary
  64  	 (if (= mdi 0x40)
  65  	     (begin
  66  	       (set 'ii 0)
  67  	       (set 'in (dup 0 16))
  68  	       (for (i 0 15 1)
  69  		    (nth-set (in i) (| (<< (char->int (md5-in (+ ii 3))) 24)
  70  				       (<< (char->int (md5-in (+ ii 2))) 16)
  71  				       (<< (char->int (md5-in (+ ii 1))) 8)
  72  				       (char->int (md5-in ii))))
  73  		    (set 'ii (+ ii 4)))
  74  	       (transform  in)
  75  	       (set 'mdi 0)))
  76  	 (set 'inlen (- inlen 1))))
  77  
  78  (define (char->int x)
  79    (if (integer? x) x (char x)))
  80  
  81  (define (md5-final)
  82    (set 'in (dup 0 16))
  83  
  84    ;; save number of bits
  85    (nth-set (in 14) (md5-i 0))
  86    (nth-set (in 15) (md5-i 1))
  87  
  88    ;; compute number of bytse mod 64
  89    (set 'mdi (& (>> (md5-i 0) 3) 0x3f))
  90  
  91    ;; pad out to 56 mod 64
  92    (if (< mdi 56)
  93        (set 'padlen (- 56 mdi))
  94        (set 'padlen (- 120 mdi)))
  95  
  96    (set 'padding (dup 0 64))
  97    (nth-set (padding 0) 0x80)
  98    (md5-update padding padlen)
  99  
 100    ;; append lenth in bits and transform
 101    (set 'ii 0)
 102    (for (i 0 13 1)
 103         (nth-set (in i) (| (<< (char->int (md5-in (+ ii 3))) 24)
 104  			  (<< (char->int (md5-in (+ ii 2))) 16)
 105  			  (<< (char->int (md5-in (+ ii 1))) 8) (char->int (md5-in ii))))
 106         (set 'ii (+ ii 4)))
 107    (transform in)
 108  
 109    ;; store buffer in digest
 110    (set 'ii 0)
 111    (for (i 0 3 1)
 112         (nth-set (md5-digest ii) (& (md5-buf i) 0xff))
 113         (nth-set (md5-digest (+ ii 1)) (& (>> (md5-buf i) 8) 0xff))
 114         (nth-set (md5-digest (+ ii 2)) (& (>> (md5-buf i) 16)  0xff))
 115         (nth-set (md5-digest (+ ii 3)) (& (>> (md5-buf i) 24)  0xff))
 116         (set 'ii (+ ii 4))))
 117  
 118  (define (transform  in)
 119    (set 'a (md5-buf 0))
 120    (set 'b (md5-buf 1))
 121    (set 'c (md5-buf 2))
 122    (set 'd (md5-buf 3))
 123  
 124    ;; Round 1
 125    (set 'S11 7)
 126    (set 'S12 12)
 127    (set 'S13 17)
 128    (set 'S14 22)
 129    (set 'a (FF a b c d (in 0) S11 3614090360)) 
 130    (set 'd (FF d a b c (in 1) S12 3905402710)) 
 131    (set 'c (FF c d a b (in 2) S13  606105819)) 
 132    (set 'b (FF b c d a (in 3) S14 3250441966)) 
 133    (set 'a (FF a b c d (in 4) S11 4118548399)) 
 134    (set 'd (FF d a b c (in 5) S12 1200080426)) 
 135    (set 'c (FF c d a b (in 6) S13 2821735955)) 
 136    (set 'b (FF b c d a (in 7) S14 4249261313)) 
 137    (set 'a (FF a b c d (in 8) S11 1770035416)) 
 138    (set 'd (FF d a b c (in 9) S12 2336552879)) 
 139    (set 'c (FF c d a b (in 10) S13 4294925233))
 140    (set 'b (FF b c d a (in 11) S14 2304563134))
 141    (set 'a (FF a b c d (in 12) S11 1804603682))
 142    (set 'd (FF d a b c (in 13) S12 4254626195))
 143    (set 'c (FF c d a b (in 14) S13 2792965006))
 144    (set 'b (FF b c d a (in 15) S14 1236535329))
 145  
 146    ;; Round 2 
 147    (set 'S21 5)
 148    (set 'S22 9)
 149    (set 'S23 14)
 150    (set 'S24 20)
 151    (set 'a (GG a b c d (in 1) S21 4129170786)) 
 152    (set 'd (GG d a b c (in 6) S22 3225465664)) 
 153    (set 'c (GG c d a b (in 11) S23  643717713))
 154    (set 'b (GG b c d a (in 0) S24 3921069994)) 
 155    (set 'a (GG a b c d (in 5) S21 3593408605)) 
 156    (set 'd (GG d a b c (in 10) S22   38016083))
 157    (set 'c (GG c d a b (in 15) S23 3634488961))
 158    (set 'b (GG b c d a (in 4) S24 3889429448)) 
 159    (set 'a (GG a b c d (in 9) S21  568446438)) 
 160    (set 'd (GG d a b c (in 14) S22 3275163606))
 161    (set 'c (GG c d a b (in 3) S23 4107603335)) 
 162    (set 'b (GG b c d a (in 8) S24 1163531501)) 
 163    (set 'a (GG a b c d (in 13) S21 2850285829))
 164    (set 'd (GG d a b c (in 2) S22 4243563512)) 
 165    (set 'c (GG c d a b (in 7) S23 1735328473)) 
 166    (set 'b (GG b c d a (in 12) S24 2368359562))
 167  
 168    ;; Round 3 
 169    (set 'S31 4)
 170    (set 'S32 11)
 171    (set 'S33 16)
 172    (set 'S34 23)
 173    (set 'a (HH a b c d (in 5) S31 4294588738)) 
 174    (set 'd (HH d a b c (in 8) S32 2272392833)) 
 175    (set 'c (HH c d a b (in 11) S33 1839030562))
 176    (set 'b (HH b c d a (in 14) S34 4259657740))
 177    (set 'a (HH a b c d (in 1) S31 2763975236)) 
 178    (set 'd (HH d a b c (in 4) S32 1272893353)) 
 179    (set 'c (HH c d a b (in 7) S33 4139469664)) 
 180    (set 'b (HH b c d a (in 10) S34 3200236656))
 181    (set 'a (HH a b c d (in 13) S31  681279174))
 182    (set 'd (HH d a b c (in 0) S32 3936430074)) 
 183    (set 'c (HH c d a b (in 3) S33 3572445317)) 
 184    (set 'b (HH b c d a (in 6) S34   76029189)) 
 185    (set 'a (HH a b c d (in 9) S31 3654602809)) 
 186    (set 'd (HH d a b c (in 12) S32 3873151461))
 187    (set 'c (HH c d a b (in 15) S33  530742520))
 188    (set 'b (HH b c d a (in 2) S34 3299628645)) 
 189  
 190    ;; Round 4 
 191    (set 'S41 6)
 192    (set 'S42 10)
 193    (set 'S43 15)
 194    (set 'S44 21)
 195    (set 'a (II a b c d (in 0) S41 4096336452)) 
 196    (set 'd (II d a b c (in 7) S42 1126891415)) 
 197    (set 'c (II c d a b (in 14) S43 2878612391))
 198    (set 'b (II b c d a (in 5) S44 4237533241)) 
 199    (set 'a (II a b c d (in 12) S41 1700485571))
 200    (set 'd (II d a b c (in 3) S42 2399980690)) 
 201    (set 'c (II c d a b (in 10) S43 4293915773))
 202    (set 'b (II b c d a (in 1) S44 2240044497)) 
 203    (set 'a (II a b c d (in 8) S41 1873313359)) 
 204    (set 'd (II d a b c (in 15) S42 4264355552))
 205    (set 'c (II c d a b (in 6) S43 2734768916)) 
 206    (set 'b (II b c d a (in 13) S44 1309151649))
 207    (set 'a (II a b c d (in 4) S41 4149444226)) 
 208    (set 'd (II d a b c (in 11) S42 3174756917))
 209    (set 'c (II c d a b (in 2) S43  718787259)) 
 210    (set 'b (II b c d a (in 9) S44 3951481745)) 
 211  
 212    (nth-set (md5-buf 0) (+ a (md5-buf 0)))
 213    (nth-set (md5-buf 1) (+ b (md5-buf 1)))
 214    (nth-set (md5-buf 2) (+ c (md5-buf 2)))
 215    (nth-set (md5-buf 3) (+ d (md5-buf 3))))
 216  
 217  (define (md5-string str)
 218    (md5-init)
 219    (md5-update str (length str))
 220    (md5-final)
 221    (set 'result "")
 222    (for (i 0 15 1)
 223         (set 'result (append result (format "%02x" (md5-digest i)))))
 224    result)
 225  

   1  
   2  #!/usr/bin/newlisp
   3  
   4  (print "Content-type: text/html\n\n")
   5  
   6  (print "<html><head><title>Random Haiku</title>")
   7  (print "</HEAD>")
   8  (print "<BODY>")
   9  (print "<br><br><br><br><br><table border=0 cellpadding=0 cellspacing=0 width=600><tr><td><br>")
  10  
  11  (println {<font face='verdana' size="2">})
  12  (print "<blockquote><p><p>RANDOM HAIKU<p></p><p></p>")
  13  
  14  (seed (time-of-day))
  15  
  16  (set 'adjs '( "autumn" "hidden" "bitter" "misty" "silent"
  17  	"empty" "dry" "dark" "summer" "icy"
  18  	"delicate" "quiet" "white" "cool" "spring"
  19  	"winter" "patient" "twilight" "dawn" "crimson"
  20  	"wispy" "weathered" "blue" "billowing" "broken"
  21  	"cold" "damp" "falling" "frosty" "green"
  22  	"long" "late" "lingering" "bold" "little"
  23  	"morning" "muddy" "old" "red" "rough"
  24  	"still" "small" "sparkling" "throbbing" "shy"
  25  	"wandering" "withered" "wild" "black" "young"
  26  	"holy" "solitary" "fragrant" "aged" "snowy"
  27  	"proud" "floral" "restless" "divine" "polished"
  28  	"ancient" "purple" "lively" "nameless" ))
  29  
  30  (set 'nouns '( "waterfall" "river" "breeze" "moon" "rain"
  31  	"wind" "sea" "morning" "snow" "lake"
  32  	"sunset" "pine" "shadow" "leaf" "dawn"
  33  	"glitter" "forest" "hill" "cloud" "meadow"
  34  	"sun" "glade" "bird" "brook" "butterfly"
  35  	"bush" "dew" "dust" "field" "fire"
  36  	"flower" "firefly" "feather" "grass" "haze"
  37  	"mountain" "night" "pond" "darkness" "snowflake"
  38  	"silence" "sound" "sky" "shape" "surf"
  39  	"thunder" "violet" "water" "wildflower" "wave"
  40  	"water" "resonance" "sun" "wood" "dream"
  41  	"cherry" "tree" "fog" "frost" "voice"
  42  	"paper" "frog" "smoke" "star"))
  43  
  44  (set 'verbs '( "shakes" "drifts" "has stopped" "struggles" "hears"
  45  	"has passed" "sleeps" "creeps" "flutters" "fades"
  46  	"is falling" "trickles" "murmurs" "warms" "hides"
  47  	"jumps" "is dreaming" "sleeps" "falls" "wanders"
  48  	"waits" "has risen" "stands" "dying" "is drawing"
  49  	"singing" "rises" "paints" "capturing" "flying"
  50  	"lies" "picked up" "gathers in" "invites" "separates"
  51  	"eats" "plants" "digs into" "has fallen" "weeping"
  52  	"facing" "mourns" "tastes" "breaking" "shaking"
  53  	"walks" "builds" "reveals" "piercing" "craves"
  54  	"departing" "opens" "falling" "confronts" "keeps"
  55  	"breaking" "is floating" "settles" "reaches" "illuminates"
  56  	"closes" "leaves" "explodes" "drawing"))
  57  
  58  (set 'preps '( "on" "beside" "in" "beneath" "of" "above" "under" "by"
  59  	"over" "against" "near" ))
  60  
  61  
  62  (define (get-word word-list)
  63  	(set 'word-list-size (length word-list))
  64  	(set 'word-list-index (rand word-list-size))
  65  	(set 'selected-word (nth word-list-index word-list))
  66  	(print " " selected-word " " ))
  67  
  68  (define (get-adjective)
  69  	(get-word adjs))
  70  
  71  (define (get-noun)
  72  	(get-word nouns))
  73  
  74  (define (get-verb)
  75  	(get-word verbs))
  76  
  77  (define (get-prep)
  78  	(get-word preps))
  79  
  80  (define (style-one)
  81  	(get-adjective)
  82  	(get-noun)
  83  	(print "<br>\n")
  84  	(get-noun)
  85  	(get-verb)
  86  	(get-prep)
  87  	(get-noun)
  88  	(print "<br>\n")
  89  	(get-adjective)
  90  	(get-adjective)
  91  	(get-noun)
  92  	(print "<br>\n"))
  93  
  94  (define (style-two)
  95  	(get-adjective)
  96  	(get-noun)
  97  	(get-verb)
  98  	(print "<br>\n")
  99  	(get-adjective)
 100  	(get-adjective)
 101  	(get-noun)
 102  	(print "<br>\n")
 103  	(get-verb)
 104  	(get-adjective)
 105  	(get-noun)
 106  	(print "<br>\n"))
 107  
 108  (define (style-three)
 109  	(get-adjective)
 110  	(get-adjective)
 111  	(get-noun)
 112  	(print "<br>\n")
 113  	(get-prep)
 114  	(get-adjective)
 115  	(get-noun)
 116  	(print "<br>\n")
 117  	(get-noun)
 118  	(get-verb)
 119  	(print "<br>\n"))
 120  
 121  (define (style-four)
 122  	(get-noun)
 123  	(get-prep)
 124  	(get-noun)
 125  	(print "<br>\n")
 126  	(get-adjective)
 127  	(get-noun)
 128  	(get-prep)
 129  	(get-noun)
 130  	(print "<br>\n")
 131  	(get-adjective)
 132  	(get-noun)
 133  	(print "<br>\n"))
 134  
 135  (define (print-haiku)
 136  	(set 'which (rand 4))
 137  	(if (= which 0)
 138  	(style-one))
 139  	(if (= which 1)
 140  	(style-two))
 141  	(if (= which 2)
 142  	(style-three))
 143  	(if (= which 3)
 144  	(style-four)))
 145  
 146  (print-haiku)
 147  
 148  (print "<p></p>")
 149  (print "<font size=1>")
 150  (println {<p>You can click <a href="haiku.cgi">HERE</a> to see a new poem.})
 151  (print "<p> Haiku generated in the style of Matsuo Basho, the Japanese poet of the 17th century.<br>
 152  This haiku program originally written in pygmy <b>FORTH</b> by Kent Peterson.<br>Translated into <b>lisp</b>.")
 153  (print "</blockquote> </table> </font> </body>\n</html>\n")
 154  
 155  (exit)
 156  
 157  
 158