; author: kathi dutton
; date:   fall 1999
; line:   a random limerick generator
; file:   limerick.l
;--------------------------------------------------------------------
; elaboration: 

;--------------------------------------------------------------------
; enter clos

  ( in-package "pcl" )

;--------------------------------------------------------------------
; create a class for word entry

  ( defclass word-entry ()
    (
     ( word :accessor word-entry-word :initarg :word )
     ( syllables :accessor word-entry-syllables :initarg :syllables )
     ( stresses :accessor word-entry-stresses :initarg :stresses )
     ( sounds :accessor word-entry-sounds :initarg :sounds )
     ( rhyme-class :accessor word-entry-rhyme-class :initarg :rhyme-class )
    )
  )

; a pretty print display method (busted!- kinda)

  ( defmethod pp-display ( (e word-entry) )
    ( setf word (word-entry-word e) )
    ( setf syllables (word-entry-syllables e) )
    ( setf stresses (word-entry-stresses e) )
    ( cond 
      ( ( = ( length syllables ) 1 )
        ( princ-ee word )
      )
      ( t
        ( princ-lc word )
        ( princ " " )
        ( dotimes (x (length syllables) )
          ( setf syllable (nth x syllables) )
          ( setf stress (nth x stresses) )
          ( if (eq stress 'hi)
              ( princ-uc syllable )
              ( princ-lc syllable )
          )
          ( princ " " )
        )
        ( dotimes (x (length stresses) )
          ( setf stress (nth x stresses) )
          ( princ-uc stress )
          ( princ " " )
        )
        
      )
     )
    ( terpri )
   )  

   ( defmethod princ-uc ( (s symbol) )
     ( princ (string-upcase ( string s )  ) )
   )
   
   ( defmethod princ-lc ( (s symbol) )
     ( princ (string-downcase ( string s ) ) )
   )
   ( defmethod princ-ee ( (s symbol) )
     ( princ "|" ) ( princ (string-downcase ( string s ))  ) ( princ "|" )
   )


 
; create a lexicon class

   ( defclass lexicon ()
     (
      ( size :accessor lexicon-size :initarg :size )
      ( words :accessor lexicon-words :initarg :words)
     )
   )

; method to display the contents of a lexicon (spent hours going nowhere because of not understand
;           just when and why ' is used! it is definitely not used where i used it)


   ( defmethod display ( (l lexicon) )
     ( setf words (lexicon-words l) )
     ( dolist ( e words )
       (pp-display e)
     )
   ) 

; a method to create an lexicon

  ( defmethod create-lexicon ((words list))
    ( setf x (length words) )
    ( setf lexicon (make-instance 'lexicon :size x :words words) )
  ) 

; class named iamb

  ( defclass iamb ()
    (
     ( size :accessor iamb-size :initarg :size )
     ( words :accessor iamb-words :initarg :words)
    )
  )

; a method to display an iamb

  ( defmethod display ( (i iamb) )
    ( setf i-list (iamb-words i) )
    ( dolist (w i-list)
      ( prin1 w ) (princ " ")
    )
    (terpri)
  )

; a method to generate an iamb

  ( defmethod generate-iamb ()
    ( setf rn (random-low-high 1 2) )
      ( cond 
        ( ( = rn 1 ) (generate-iamb-1 lexicon) )
        ( ( = rn 2 ) (generate-iamb-2 lexicon) )
      )
  )

; generate-iamb one variable

  ( defmethod generate-iamb ((x symbol))
    ( setf rn (random-low-high 1 2) )
      ( cond
        ( ( = rn 1 ) ( (generate-iamb-1 lexicon x) ) )
        ( ( = rn 2 ) ( (generate-iamb-2 lexicon x) ) )
      )
  )

; method genrate-iamb-1 finds one word two syllables

  ( defmethod generate-iamb-1 ((l lexicon))
    ( setf words ( lexicon-words l) )
    ( setf iamb-list () )
    ( dolist (word words )
      ( setf we (word-entry-word word) )
      ( setf syl (word-entry-syllables word) )
      ( if ( = (length syl) 2) 
          ( setf iamb-list (append iamb-list (list we) ) )
      )
    )
    ( setf high (length iamb-list) )
    ( setf rn (random-low-high 1 high) )
    ( setf times 0 )
    ( dotimes (x (length iamb-list) ) 
      ( setf times (+ times 1) ) 
        ( cond
          ( ( = rn times ) ( setf we (nth x iamb-list) ) )
        )  
    )      
    (setf iam (make-instance 'iamb :size 1 :words (list we) ) )
  )

; generate-iamb-2 generate a two word iamb

  ( defmethod generate-iamb-2 ((l lexicon) )
    ( setf words ( lexicon-words l ) )
    ( setf iamb-list () )
    ( setf result () )
    ( dolist ( word words )
      ( setf we (word-entry-word word) )
      ( setf syl (word-entry-syllables word) )
      ( if ( = (length syl) 1)
          ( setf iamb-list (append iamb-list (list we) ) )
      )
    )
    ( setf high (length iamb-list) )
    ( setf rn1 (random-low-high 1 high) )
    ( setf rn2 (random-low-high 1 high) )
    ( setf times 0 )
    ( dotimes (x (length iamb-list) )
      ( setf times ( + times 1 ) )
        ( cond 
          ( ( = rn1 times ) ( setf we1 (nth x iamb-list) ) )
          ( ( = rn2 times ) ( setf we2 (nth x iamb-list) ) )
        )  
     )
    ( setf result (append result (list we1)) )
    ( setf result (append result (list we2)) )
    ( setf iam (make-instance 'iamb :size 2 :words result) )
   ) 

; method genrate-iamb-1 finds one word two syllables with 2 variables

  ( defmethod generate-iamb-1 ((l lexicon) (x symbol))
    ( setf words ( lexicon-words l) )
    ( setf iamb-list () )
    ( setf iambx-list () )
    ( dolist (word words )
      ( setf we (word-entry-word word) )
      ( setf syl (word-entry-syllables word) )
      ( if ( = (length syl) 2)
          ( setf iamb-list (append iamb-list (list we) ) )
      )
    )
    ( dolist (word iamb-list)
      ( setf we (word-entry-word word) )
      ( setf r-class (word-entry-rhyme-class word) )
      ( if ( = r-class x )
          ( setf iambx-list (append iambx-list (list we) ) )
      )
    ( setf high (length iambx-list) )
    ( setf rn (random-low-high 1 high) )
    ( setf times 0 )
    ( dotimes (x (length iambx-list) )
      ( setf times (+ times 1) )
        ( cond
          ( ( = rn times ) ( setf we (nth x iambx-list) ) )
        )
    )
    (setf iam (make-instance 'iamb :size 1 :words (list we) ) )
   )

; class named anapest

  ( defclass anapest ()
    (
     ( size :accessor anapest-size :initarg :size )
     ( words :accessor anapest-words :initarg :words)
    )
  )

; a method to display an anapest

  ( defmethod display ( (a anapest) )
    ( setf a-list (anapest-words a) )
    ( dolist (w a-list)
      ( prin1 w ) (princ " ")
    )
    (terpri)
  )

    
; a method to generate an anapest

  ( defmethod generate-anapest ()
    ( setf rn (random-low-high 1 3) )
      ( cond 
        ( ( = rn 1 ) (generate-anapest-1 lexicon) )
        ( ( = rn 2 ) (generate-anapest-2 lexicon) )
        ( ( = rn 3 ) (generate-anapest-3 lexicon) )
      )
  )

; method genrate-anapest-1 finds one word three syllables

  ( defmethod generate-anapest-1 ((l lexicon))
    ( setf words ( lexicon-words l) )
    ( setf anapest-list () )
    ( dolist (word words )
      ( setf we (word-entry-word word) )
      ( setf syl (word-entry-syllables word) )
      ( if ( = (length syl) 3) 
          ( setf anapest-list (append anapest-list (list we) ) )
      )
    )
    ( setf high (length anapest-list) )
    ( setf rn (random-low-high 1 high) )
    ( setf times 0 )
    ( dotimes (x (length anapest-list) ) 
      ( setf times (+ times 1) ) 
        ( cond
          ( ( = rn times ) ( setf we (nth x anapest-list) ) )
        )  
    )      
    (setf ana (make-instance 'anapest :size 1 :words (list we) ) ) 
  )

; generate-anapest-2 generate a two word anapest

  ( defmethod generate-anapest-2 ((l lexicon) )
    ( setf words ( lexicon-words l ) )
    ( setf anapest1-list () )
    ( setf anapest2-list () )
    ( setf result () )
    ( dolist ( word words )
      ( setf we (word-entry-word word) )
      ( setf syl (word-entry-syllables word) )
      ( if ( = (length syl) 1)
          ( setf anapest1-list (append anapest1-list (list we) ) )
      )
      ( if ( = (length syl) 2)
          ( setf anapest2-list (append anapest2-list (list we) ) )
      )  
    )
    ( setf high ( + (length anapest1-list) (length anapest2-list) ) )
    ( setf rn1 (random-low-high 1 high) )
    ( setf rn2 (random-low-high 1 high) )
    ( setf times 0 )
    ( dotimes (x (length anapest1-list) )
      ( setf times ( + times 1 ) )
        ( cond 
          ( ( = rn1 times ) ( setf we1 (nth x anapest1-list) ) )
        )
    )
    ( setf times 0 )
    ( dotimes (x (length anapest2-list) )
      ( setf times ( + times 1 ) )
        ( cond
          ( ( = rn2 times ) ( setf we2 (nth x anapest2-list) ) )
        )  
    )
    ( setf result (append result (list we1)) )
    ( setf result (append result (list we2)) )
     (setf ana (make-instance 'anapest :size 2 :words result ) )
   )    

; generate-anapest-3 generate a three word anapest

  ( defmethod generate-anapest-3 ((l lexicon) )
    ( setf words ( lexicon-words l ) )
    ( setf anapest1-list () )
    ( setf result () )
    ( dolist ( word words )
      ( setf we (word-entry-word word) )
      ( setf syl (word-entry-syllables word) )
      ( if ( = (length syl) 1)
          ( setf anapest1-list (append anapest1-list (list we) ) )
      )
    )
    ( setf high (length anapest1-list) )
    ( setf rn1 (random-low-high 1 high) )
    ( setf rn2 (random-low-high 1 high) )
    ( setf rn3 (random-low-high 1 high) )
    ( setf times 0 )
    ( dotimes (x (length anapest1-list) )
      ( setf times ( + times 1 ) )
        ( cond 
          ( ( = rn1 times ) ( setf we1 (nth x anapest1-list) ) )
          ( ( = rn2 times ) ( setf we2 (nth x anapest1-list) ) )
          ( ( = rn3 times ) ( setf we3 (nth x anapest1-list) ) )
        )
    )
    ( setf result (append result (list we1)) )
    ( setf result (append result (list we2)) )
    ( setf result (append result (list we3)) )
    (setf ana (make-instance 'anapest :size 3 :words result ) )
   )    

; class limerick

   ( defclass limerick () 
     (
      ( line1 :accessor limerick-line1 :initarg :line1 ) 
      ( line2 :accessor limerick-line2 :initarg :line2 )
      ( line3 :accessor limerick-line3 :initarg :line3 )
      ( line4 :accessor limerick-line4 :initarg :line4 )
      ( line5 :accessor limerick-line5 :initarg :line5 )
     )
   )

; to randomly generate a very bad (hopefully not offensive) limerick

   ( defmethod generate-limerick ((lex lexicon))
     ( setf x (select-rhyme-class) )
     ( setf y (select-rhyme-class) ) 
     ( setf line1 (generate-iaa x) ) 
     ( setf line2 (generate-iaa x) ) 
     ( setf line3 (generate-ia y) ) 
     ( setf line4 (generate-ia y) ) 
     ( setf line5 (generate-iaa x) ) 
     ( setf limerick (make-instance 'limerick :line1 line1 :line2 line2 
                                    :line3 line3 :line4 line4 :line5 line5) )
   )

; method select-rhyme-class

   ( defmethod select-rhyme-class ()
     ( setf rn (random-low-high 1 9) )
       ( cond
         ( ( = rn 1 ) ( setf r 'a ) )
         ( ( = rn 2 ) ( setf r 'b ) )
         ( ( = rn 3 ) ( setf r 'c ) )
         ( ( = rn 4 ) ( setf r 'd ) )
         ( ( = rn 5 ) ( setf r 'e ) )
         ( ( = rn 6 ) ( setf r 'f ) )
         ( ( = rn 7 ) ( setf r 'g ) )
         ( ( = rn 8 ) ( setf r 'h ) )
         ( ( = rn 9 ) ( setf r 'i ) )
       )
    )  

; generate-iaa which consists of iamb anapest anapest

    ( defmethod generate-iaa (( x symbol))
      ( setf i (generate-iamb x) )
      ( setf a1 (generate-anapest x) )
      ( setf a2 (generate-anapest x) )


; random number generator

    ( defun random-low-high ( low high &aux spread xrn rn )
      ( setf spread ( + ( - high low ) 1 ) ) 
      ( setf xrn ( random spread ) )
      ( setf rn ( + low xrn ) )  rn)