4 Replies - 2171 Views - Last Post: 02 June 2011 - 04:47 PM

#1 cyberscribe   User is offline

  • humble.genius
  • member icon

Reputation: 10
  • View blog
  • Posts: 1,062
  • Joined: 05-May 02

[Lisp] Computer Generated HAIKU

Posted 15 February 2005 - 11:29 AM

Description: Requires a database of nouns, adjectives, adverbs, and verbs in the correct format. Mostly here for historical purposes. :)

This program takes MadLibs-style patterns and fills them, using the a database of nouns, adjectives, adverbs, and verbs collected by Princeton University and distributed with WordNet (not included with the sourcecode). It thereby generates "HAIKU" according to the 5-7-5 syllable scheme.

(define (eval-item symbol)
  (display (eval (list symbol))) (newline))

(define (do-haiku times)
  (map eval-item (haiku-list times)))

(define (haiku-list times)
  (cond ((= 0 times) '())
        (else (cons 'haiku (haiku-list (- times 1))))))

(define (haiku)
  (display (make-caps (line1))) (newline) 
  (display (line2)) (newline) 
  (display (put-period (line3))) 
  (newline))

(define (rough-haiku)
  (list (line1) (line2) (line3))
  )

(define (make-caps L)
  (cons (capitalize (car L)) (cdr L)) )

(define (put-period L)
  (reverse (cons (period (car (reverse L))) (cdr (reverse L)))))
  
(define (capitalize symbol-word)
  (implode-char (cons (char-upcase (car (explode-char symbol-word))) (cdr (explode-char symbol-word)))))

(define (period symbol-word)
  (implode-char (reverse (cons '#. (reverse (explode-char symbol-word))))))

(define templates1 '( ( (verbs gerund) (nouns) )
                     ( (nouns) (verbs) (adverbs) )
                     ( (adjectives) (nouns) ) 
                     ))

(define templates2 '( ( (verbs) (verbs) (verbs) )
                     ( (adjectives) (nouns) )
                     ( (nouns) (verbs gerund) (adverbs) ) 
                     ))

(define templates3 '( ( (adjectives) (nouns) )
                     ( (verbs gerund) (adverbs) )
                     ( (verbs gerund) (nouns) )
                     ))

(define (line1)
  (map make-word (syl-dist (pick-random templates1) 5)))

(define (line2)
  (map make-word (syl-dist (pick-random templates2) 7)))

(define (line3)
  (map make-word (syl-dist (pick-random templates3) 5)))

(define (make-word spec-list)
  (cond ((null? (cddr spec-list)) (get-word spec-list))
        ((and (equal? 'verbs (second spec-list)) (= 1 (first spec-list)))
         (get-word spec-list))
        ((equal? 'gerund (third spec-list)) 
         (gerund (get-word (cons (- (car spec-list) 1) (cdr spec-list)))))
        (else (get-word spec-list))))

;;;;;;General-use functions

(define (last a-list)
  (car (reverse a-list)))

;Returns #t if E is in list L, #f otherwise

(define (contains? e L)
  (cond ((null? L) #f)
        ((equal? e (car L)) #t)
        (else (contains? e (cdr L)))))

;Turns a symbol into a list of it's constituent symbol charachters

(define (explode sym)
    (map string->symbol
         (map string
              (string->list (symbol->string sym)))) )

;Turns a symbol into a list of it's constituent charachters

(define (explode-char sym)
              (string->list (symbol->string sym)))


;Turns a symbol into a list of it's constituent symbol charachters, removing "_"

(define (explode-remove sym)
    (map string->symbol
         (map string
              (replace #_ # (string->list (symbol->string sym))))) )

;Inverse of explode

(define (implode L)
  (list (string->symbol
       (apply string-append
            (map symbol->string L)))))

;Turns a charachter list into a symbol

(define (implode-char c-list)
  (string->symbol (list->string c-list)) )

;implodes list to a string

(define (implode-string L)
       (apply string-append
            (map symbol->string L)))

;Returns number of instances when list contains A then B, in L, 0 otherwise

(define (count-sequence A B L)
  (cond ((null? L) 0)
        ((null? (cdr L)) 0)
        ((and (equal? A (car L)) (equal? B (cadr L)))
         (+ 1 (count-sequence A B (cdr L))))
        (else (count-sequence A B (cdr L)))))

;Replaces all cases of a with b in list L

(define (replace a b L)
  (cond ((null? L) '())
        ((equal? (car L) a) (cons b (replace a b (cdr L))))
        (else (cons (car L) (replace a b (cdr L)))) ))

;Replaces first case of a with b in list L

(define (replace* a b L)
  (cond ((null? L) '())
        ((equal? (car L) a) (cons b (cdr L)))
        (else (cons (car L) (replace a b (cdr L)))) ))

;Picks a random element from the available top-level elements in A-LIST

(define (pick-random a-list)
  (list-ref a-list (random (length a-list))))

;returns #t if WORD ends in ENDING, #f otherwise

(define (ends-in? ending word)
  (if (equal? (reverse (subseq (explode word) (- (length (explode word)) (length (explode ending)))))
              (reverse (explode ending))) #t #f))

;Picks a word of the given type and syllable count

(define (pick-for syl type)
  (let* ( (seed (pick-random type)) )
    (if (= syl (syllables seed))
        seed (pick-for syl type))))

;Returns the word specified by the first two elements of SPEC-LIST

(define (get-word spec-list)
  (eval (list 'pick-for (car spec-list) (cadr spec-list))))

;;;;;;The syllable-counting function and it's sub-functions

(define (syllables word)
  (cond ((> 4 (length (explode word))) (syl-after-conditions word))
        ((ends-in? 'able word)
         (+ 1 (syl-after-conditions word)))
        ((ends-in? 'ible word)
         (+ 1 (syl-after-conditions word)))
         (else (syl-after-conditions word))))

(define (syl-after-conditions word)
  (cond ((equal? 'the word) 1)
        ((contains? '_ (explode word)) (_syllables word))
        ((equal? 'e (last (explode word)))
         (- (aug-syl (reverse (cdr (reverse (explode word))))) 
            (count-sequence 'e '_ (explode word))))
        (- (aug-syl (explode word)) (count-sequence 'e '_ (explode word)))))

(define (_syllables word)
  (cond ((and (equal? 'T (car (explode word)))
              (equal? 'h (cadr (explode word)))
              (equal? 'e (caddr (explode word))))
          (+ (- (aug-syl (explode word)) (count-sequence 'e '_ (explode word)))
            1))
        (else (- (aug-syl (explode word)) (count-sequence 'e '_ (explode word)))
            )))

(define (aug-syl L)
   (if (= 0 (count #t (remove-duplicates 
                                   (map equal-to-vowel? L)))) 1
   (count #t (remove-duplicates 
                                   (map equal-to-vowel? L)))))

(define (equal-to-vowel? letter)
  (or (equal? 'a letter)
      (equal? 'e letter)
      (equal? 'i letter)
      (equal? 'o letter)
      (equal? 'u letter)
      (equal? 'y letter)))

(define (remove-duplicates L)
  (cond ((null? L) '())
        ((null? (cdr L)) L)
        ((equal? (first L) (second L)) (remove-duplicates (cdr L)))
        (else (cons (first L) (remove-duplicates (cdr L))))) )

;;;;;;The syllable-distributing function and it's sub-functions


(define (syl-dist lists syl)
  (syl-finisher (syl-evener lists syl) (- syl (*
                                         (truncate (/ syl (length lists)))
                                         (length lists))) ))
(define (cons-1 L)
  (cons '1 L))

(define (cons-2 L)
  (cons '2 L))

(define (cons-3 L)
  (cons '3 L))

(define (cons-4 L)
  (cons '4 L))

(define (cons-5 L)
  (cons '5 L))

(define (cons-6 L)
  (cons '6 L))

(define (cons-7 L)
  (cons '7 L))

(define (syl-evener lists syl)
  (cond ((< syl (length lists)) 'more-words-than-syllables!)
        ((= syl (length lists)) (map cons-1 lists))
        ((= 1 (truncate (/ syl (length lists)))) (map cons-1 lists))
        ((= 2 (truncate (/ syl (length lists)))) (map cons-2 lists))
        ((= 3 (truncate (/ syl (length lists)))) (map cons-3 lists))
        ((= 4 (truncate (/ syl (length lists)))) (map cons-4 lists))
        ((= 5 (truncate (/ syl (length lists)))) (map cons-5 lists))
        ((= 6 (truncate (/ syl (length lists)))) (map cons-6 lists))
        ((= 7 (truncate (/ syl (length lists)))) (map cons-7 lists))
        (else 'unexpected-error-in-syl-evener)))

(define (syl-finisher lists syl-remaining)
  (let ( (random-phrase (pick-random lists) ) )
    (replace* random-phrase 
             (cons (+ syl-remaining (car random-phrase)) (cdr random-phrase)) 
             lists)))

;;;;;;The gerund fucntion and it's sub-functions

(define (gerund symbol-word)
  (if (contains? '_
                 (explode symbol-word))
      (gerund (pick-for (syllables symbol-word) verbs))
      (make-gerund symbol-word)))
  
  
(define (make-gerund symbol)
  (string->symbol (add-ing (modify-ing (delete-ending "e" (symbol->string symbol))))))

(define (modify-ing string-word)
  (let* ((char-list (string->list string-word))
        (last-char (last char-list)))
    (if (or (equal? last-char #b)
            (equal? last-char #d)
            (equal? last-char #m)
            (equal? last-char #n)
            (equal? last-char #p)
            (equal? last-char #r))
        (double-last string-word) string-word)))

(define (double-last string-word)
  (let* ((char-list (string->list string-word))
        (last-char (last char-list)))
    (list->string (reverse (cons last-char (reverse char-list))))))
    
(define (delete-ending string-ending string-word)
  (if (eqv? (car (string->list string-ending)) 
            (car (reverse (string->list string-word))))
      (list->string (reverse (cdr (reverse (string->list string-word)))))
      string-word))

(define (add-ing string-word)
(list->string (reverse (cons #g (cons #n (cons #i 
(reverse (string->list string-word))))))))



Is This A Good Question/Topic? 0
  • +

Replies To: [Lisp] Computer Generated HAIKU

#2 amos   User is offline

  • D.I.C Head

Reputation: 0
  • View blog
  • Posts: 146
  • Joined: 17-April 05

Re: [Lisp] Computer Generated HAIKU

Posted 13 September 2009 - 07:01 AM

Any idea where you can get a dictionary in the required format?
Was This Post Helpful? 0
  • +
  • -

#3 marlonjamera   User is offline

  • New D.I.C Head

Reputation: 0
  • View blog
  • Posts: 6
  • Joined: 30-January 09

Re: [Lisp] Computer Generated HAIKU

Posted 03 February 2010 - 06:39 AM

is this prolog?
Was This Post Helpful? 0
  • +
  • -

#4 I X Code X 1   User is offline

  • D.I.C Head
  • member icon

Reputation: 47
  • View blog
  • Posts: 66
  • Joined: 28-July 10

Re: [Lisp] Computer Generated HAIKU

Posted 02 June 2011 - 04:47 PM

Very nice!
Was This Post Helpful? 0
  • +
  • -

#5 I X Code X 1   User is offline

  • D.I.C Head
  • member icon

Reputation: 47
  • View blog
  • Posts: 66
  • Joined: 28-July 10

Re: [Lisp] Computer Generated HAIKU

Posted 02 June 2011 - 04:47 PM

Very nice!
Was This Post Helpful? 0
  • +
  • -

#6 cyberscribe   User is offline

  • humble.genius
  • member icon

Reputation: 10
  • View blog
  • Posts: 1,062
  • Joined: 05-May 02

Re: [Lisp] Computer Generated HAIKU

Posted 15 February 2005 - 11:29 AM

Description: Requires a database of nouns, adjectives, adverbs, and verbs in the correct format. Mostly here for historical purposes. :)This program takes MadLibs-style patterns and fills them, using the a database of nouns, adjectives, adverbs, and verbs collected by Princeton University and distributed with WordNet (not included with the sourcecode). It thereby generates "HAIKU" according to the 5-7-5 syllable scheme. TEST EDIT
(define (eval-item symbol)
  (display (eval (list symbol))) (newline))

(define (do-haiku times)
  (map eval-item (haiku-list times)))

(define (haiku-list times)
  (cond ((= 0 times) '())
        (else (cons 'haiku (haiku-list (- times 1))))))

(define (haiku)
  (display (make-caps (line1))) (newline) 
  (display (line2)) (newline) 
  (display (put-period (line3))) 
  (newline))

(define (rough-haiku)
  (list (line1) (line2) (line3))
  )

(define (make-caps L)
  (cons (capitalize (car L)) (cdr L)) )

(define (put-period L)
  (reverse (cons (period (car (reverse L))) (cdr (reverse L)))))
  
(define (capitalize symbol-word)
  (implode-char (cons (char-upcase (car (explode-char symbol-word))) (cdr (explode-char symbol-word)))))

(define (period symbol-word)
  (implode-char (reverse (cons '#. (reverse (explode-char symbol-word))))))

(define templates1 '( ( (verbs gerund) (nouns) )
                     ( (nouns) (verbs) (adverbs) )
                     ( (adjectives) (nouns) ) 
                     ))

(define templates2 '( ( (verbs) (verbs) (verbs) )
                     ( (adjectives) (nouns) )
                     ( (nouns) (verbs gerund) (adverbs) ) 
                     ))

(define templates3 '( ( (adjectives) (nouns) )
                     ( (verbs gerund) (adverbs) )
                     ( (verbs gerund) (nouns) )
                     ))

(define (line1)
  (map make-word (syl-dist (pick-random templates1) 5)))

(define (line2)
  (map make-word (syl-dist (pick-random templates2) 7)))

(define (line3)
  (map make-word (syl-dist (pick-random templates3) 5)))

(define (make-word spec-list)
  (cond ((null? (cddr spec-list)) (get-word spec-list))
        ((and (equal? 'verbs (second spec-list)) (= 1 (first spec-list)))
         (get-word spec-list))
        ((equal? 'gerund (third spec-list)) 
         (gerund (get-word (cons (- (car spec-list) 1) (cdr spec-list)))))
        (else (get-word spec-list))))

;;;;;;General-use functions

(define (last a-list)
  (car (reverse a-list)))

;Returns #t if E is in list L, #f otherwise

(define (contains? e L)
  (cond ((null? L) #f)
        ((equal? e (car L)) #t)
        (else (contains? e (cdr L)))))

;Turns a symbol into a list of it's constituent symbol charachters

(define (explode sym)
    (map string->symbol
         (map string
              (string->list (symbol->string sym)))) )

;Turns a symbol into a list of it's constituent charachters

(define (explode-char sym)
              (string->list (symbol->string sym)))


;Turns a symbol into a list of it's constituent symbol charachters, removing "_"

(define (explode-remove sym)
    (map string->symbol
         (map string
              (replace #_ # (string->list (symbol->string sym))))) )

;Inverse of explode

(define (implode L)
  (list (string->symbol
       (apply string-append
            (map symbol->string L)))))

;Turns a charachter list into a symbol

(define (implode-char c-list)
  (string->symbol (list->string c-list)) )

;implodes list to a string

(define (implode-string L)
       (apply string-append
            (map symbol->string L)))

;Returns number of instances when list contains A then B, in L, 0 otherwise

(define (count-sequence A B L)
  (cond ((null? L) 0)
        ((null? (cdr L)) 0)
        ((and (equal? A (car L)) (equal? B (cadr L)))
         (+ 1 (count-sequence A B (cdr L))))
        (else (count-sequence A B (cdr L)))))

;Replaces all cases of a with b in list L

(define (replace a b L)
  (cond ((null? L) '())
        ((equal? (car L) a) (cons b (replace a b (cdr L))))
        (else (cons (car L) (replace a b (cdr L)))) ))

;Replaces first case of a with b in list L

(define (replace* a b L)
  (cond ((null? L) '())
        ((equal? (car L) a) (cons b (cdr L)))
        (else (cons (car L) (replace a b (cdr L)))) ))

;Picks a random element from the available top-level elements in A-LIST

(define (pick-random a-list)
  (list-ref a-list (random (length a-list))))

;returns #t if WORD ends in ENDING, #f otherwise

(define (ends-in? ending word)
  (if (equal? (reverse (subseq (explode word) (- (length (explode word)) (length (explode ending)))))
              (reverse (explode ending))) #t #f))

;Picks a word of the given type and syllable count

(define (pick-for syl type)
  (let* ( (seed (pick-random type)) )
    (if (= syl (syllables seed))
        seed (pick-for syl type))))

;Returns the word specified by the first two elements of SPEC-LIST

(define (get-word spec-list)
  (eval (list 'pick-for (car spec-list) (cadr spec-list))))

;;;;;;The syllable-counting function and it's sub-functions

(define (syllables word)
  (cond ((> 4 (length (explode word))) (syl-after-conditions word))
        ((ends-in? 'able word)
         (+ 1 (syl-after-conditions word)))
        ((ends-in? 'ible word)
         (+ 1 (syl-after-conditions word)))
         (else (syl-after-conditions word))))

(define (syl-after-conditions word)
  (cond ((equal? 'the word) 1)
        ((contains? '_ (explode word)) (_syllables word))
        ((equal? 'e (last (explode word)))
         (- (aug-syl (reverse (cdr (reverse (explode word))))) 
            (count-sequence 'e '_ (explode word))))
        (- (aug-syl (explode word)) (count-sequence 'e '_ (explode word)))))

(define (_syllables word)
  (cond ((and (equal? 'T (car (explode word)))
              (equal? 'h (cadr (explode word)))
              (equal? 'e (caddr (explode word))))
          (+ (- (aug-syl (explode word)) (count-sequence 'e '_ (explode word)))
            1))
        (else (- (aug-syl (explode word)) (count-sequence 'e '_ (explode word)))
            )))

(define (aug-syl L)
   (if (= 0 (count #t (remove-duplicates 
                                   (map equal-to-vowel? L)))) 1
   (count #t (remove-duplicates 
                                   (map equal-to-vowel? L)))))

(define (equal-to-vowel? letter)
  (or (equal? 'a letter)
      (equal? 'e letter)
      (equal? 'i letter)
      (equal? 'o letter)
      (equal? 'u letter)
      (equal? 'y letter)))

(define (remove-duplicates L)
  (cond ((null? L) '())
        ((null? (cdr L)) L)
        ((equal? (first L) (second L)) (remove-duplicates (cdr L)))
        (else (cons (first L) (remove-duplicates (cdr L))))) )

;;;;;;The syllable-distributing function and it's sub-functions


(define (syl-dist lists syl)
  (syl-finisher (syl-evener lists syl) (- syl (*
                                         (truncate (/ syl (length lists)))
                                         (length lists))) ))
(define (cons-1 L)
  (cons '1 L))

(define (cons-2 L)
  (cons '2 L))

(define (cons-3 L)
  (cons '3 L))

(define (cons-4 L)
  (cons '4 L))

(define (cons-5 L)
  (cons '5 L))

(define (cons-6 L)
  (cons '6 L))

(define (cons-7 L)
  (cons '7 L))

(define (syl-evener lists syl)
  (cond ((< syl (length lists)) 'more-words-than-syllables!)
        ((= syl (length lists)) (map cons-1 lists))
        ((= 1 (truncate (/ syl (length lists)))) (map cons-1 lists))
        ((= 2 (truncate (/ syl (length lists)))) (map cons-2 lists))
        ((= 3 (truncate (/ syl (length lists)))) (map cons-3 lists))
        ((= 4 (truncate (/ syl (length lists)))) (map cons-4 lists))
        ((= 5 (truncate (/ syl (length lists)))) (map cons-5 lists))
        ((= 6 (truncate (/ syl (length lists)))) (map cons-6 lists))
        ((= 7 (truncate (/ syl (length lists)))) (map cons-7 lists))
        (else 'unexpected-error-in-syl-evener)))

(define (syl-finisher lists syl-remaining)
  (let ( (random-phrase (pick-random lists) ) )
    (replace* random-phrase 
             (cons (+ syl-remaining (car random-phrase)) (cdr random-phrase)) 
             lists)))

;;;;;;The gerund fucntion and it's sub-functions

(define (gerund symbol-word)
  (if (contains? '_
                 (explode symbol-word))
      (gerund (pick-for (syllables symbol-word) verbs))
      (make-gerund symbol-word)))
  
  
(define (make-gerund symbol)
  (string->symbol (add-ing (modify-ing (delete-ending "e" (symbol->string symbol))))))

(define (modify-ing string-word)
  (let* ((char-list (string->list string-word))
        (last-char (last char-list)))
    (if (or (equal? last-char #b)
            (equal? last-char #d)
            (equal? last-char #m)
            (equal? last-char #n)
            (equal? last-char #p)
            (equal? last-char #r))
        (double-last string-word) string-word)))

(define (double-last string-word)
  (let* ((char-list (string->list string-word))
        (last-char (last char-list)))
    (list->string (reverse (cons last-char (reverse char-list))))))
    
(define (delete-ending string-ending string-word)
  (if (eqv? (car (string->list string-ending)) 
            (car (reverse (string->list string-word))))
      (list->string (reverse (cdr (reverse (string->list string-word)))))
      string-word))

(define (add-ing string-word)
(list->string (reverse (cons #g (cons #n (cons #i 
(reverse (string->list string-word))))))))

TEST EDIT

Was This Post Helpful? 0
  • +
  • -

#7 cyberscribe   User is offline

  • humble.genius
  • member icon

Reputation: 10
  • View blog
  • Posts: 1,062
  • Joined: 05-May 02

Re: [Lisp] Computer Generated HAIKU

Posted 15 February 2005 - 11:29 AM

Description: Requires a database of nouns, adjectives, adverbs, and verbs in the correct format. Mostly here for historical purposes. :)This program takes MadLibs-style patterns and fills them, using the a database of nouns, adjectives, adverbs, and verbs collected by Princeton University and distributed with WordNet (not included with the sourcecode). It thereby generates "HAIKU" according to the 5-7-5 syllable scheme.
(define (eval-item symbol)
  (display (eval (list symbol))) (newline))

(define (do-haiku times)
  (map eval-item (haiku-list times)))

(define (haiku-list times)
  (cond ((= 0 times) '())
        (else (cons 'haiku (haiku-list (- times 1))))))

(define (haiku)
  (display (make-caps (line1))) (newline) 
  (display (line2)) (newline) 
  (display (put-period (line3))) 
  (newline))

(define (rough-haiku)
  (list (line1) (line2) (line3))
  )

(define (make-caps L)
  (cons (capitalize (car L)) (cdr L)) )

(define (put-period L)
  (reverse (cons (period (car (reverse L))) (cdr (reverse L)))))
  
(define (capitalize symbol-word)
  (implode-char (cons (char-upcase (car (explode-char symbol-word))) (cdr (explode-char symbol-word)))))

(define (period symbol-word)
  (implode-char (reverse (cons '#. (reverse (explode-char symbol-word))))))

(define templates1 '( ( (verbs gerund) (nouns) )
                     ( (nouns) (verbs) (adverbs) )
                     ( (adjectives) (nouns) ) 
                     ))

(define templates2 '( ( (verbs) (verbs) (verbs) )
                     ( (adjectives) (nouns) )
                     ( (nouns) (verbs gerund) (adverbs) ) 
                     ))

(define templates3 '( ( (adjectives) (nouns) )
                     ( (verbs gerund) (adverbs) )
                     ( (verbs gerund) (nouns) )
                     ))

(define (line1)
  (map make-word (syl-dist (pick-random templates1) 5)))

(define (line2)
  (map make-word (syl-dist (pick-random templates2) 7)))

(define (line3)
  (map make-word (syl-dist (pick-random templates3) 5)))

(define (make-word spec-list)
  (cond ((null? (cddr spec-list)) (get-word spec-list))
        ((and (equal? 'verbs (second spec-list)) (= 1 (first spec-list)))
         (get-word spec-list))
        ((equal? 'gerund (third spec-list)) 
         (gerund (get-word (cons (- (car spec-list) 1) (cdr spec-list)))))
        (else (get-word spec-list))))

;;;;;;General-use functions

(define (last a-list)
  (car (reverse a-list)))

;Returns #t if E is in list L, #f otherwise

(define (contains? e L)
  (cond ((null? L) #f)
        ((equal? e (car L)) #t)
        (else (contains? e (cdr L)))))

;Turns a symbol into a list of it's constituent symbol charachters

(define (explode sym)
    (map string->symbol
         (map string
              (string->list (symbol->string sym)))) )

;Turns a symbol into a list of it's constituent charachters

(define (explode-char sym)
              (string->list (symbol->string sym)))


;Turns a symbol into a list of it's constituent symbol charachters, removing "_"

(define (explode-remove sym)
    (map string->symbol
         (map string
              (replace #_ # (string->list (symbol->string sym))))) )

;Inverse of explode

(define (implode L)
  (list (string->symbol
       (apply string-append
            (map symbol->string L)))))

;Turns a charachter list into a symbol

(define (implode-char c-list)
  (string->symbol (list->string c-list)) )

;implodes list to a string

(define (implode-string L)
       (apply string-append
            (map symbol->string L)))

;Returns number of instances when list contains A then B, in L, 0 otherwise

(define (count-sequence A B L)
  (cond ((null? L) 0)
        ((null? (cdr L)) 0)
        ((and (equal? A (car L)) (equal? B (cadr L)))
         (+ 1 (count-sequence A B (cdr L))))
        (else (count-sequence A B (cdr L)))))

;Replaces all cases of a with b in list L

(define (replace a b L)
  (cond ((null? L) '())
        ((equal? (car L) a) (cons b (replace a b (cdr L))))
        (else (cons (car L) (replace a b (cdr L)))) ))

;Replaces first case of a with b in list L

(define (replace* a b L)
  (cond ((null? L) '())
        ((equal? (car L) a) (cons b (cdr L)))
        (else (cons (car L) (replace a b (cdr L)))) ))

;Picks a random element from the available top-level elements in A-LIST

(define (pick-random a-list)
  (list-ref a-list (random (length a-list))))

;returns #t if WORD ends in ENDING, #f otherwise

(define (ends-in? ending word)
  (if (equal? (reverse (subseq (explode word) (- (length (explode word)) (length (explode ending)))))
              (reverse (explode ending))) #t #f))

;Picks a word of the given type and syllable count

(define (pick-for syl type)
  (let* ( (seed (pick-random type)) )
    (if (= syl (syllables seed))
        seed (pick-for syl type))))

;Returns the word specified by the first two elements of SPEC-LIST

(define (get-word spec-list)
  (eval (list 'pick-for (car spec-list) (cadr spec-list))))

;;;;;;The syllable-counting function and it's sub-functions

(define (syllables word)
  (cond ((> 4 (length (explode word))) (syl-after-conditions word))
        ((ends-in? 'able word)
         (+ 1 (syl-after-conditions word)))
        ((ends-in? 'ible word)
         (+ 1 (syl-after-conditions word)))
         (else (syl-after-conditions word))))

(define (syl-after-conditions word)
  (cond ((equal? 'the word) 1)
        ((contains? '_ (explode word)) (_syllables word))
        ((equal? 'e (last (explode word)))
         (- (aug-syl (reverse (cdr (reverse (explode word))))) 
            (count-sequence 'e '_ (explode word))))
        (- (aug-syl (explode word)) (count-sequence 'e '_ (explode word)))))

(define (_syllables word)
  (cond ((and (equal? 'T (car (explode word)))
              (equal? 'h (cadr (explode word)))
              (equal? 'e (caddr (explode word))))
          (+ (- (aug-syl (explode word)) (count-sequence 'e '_ (explode word)))
            1))
        (else (- (aug-syl (explode word)) (count-sequence 'e '_ (explode word)))
            )))

(define (aug-syl L)
   (if (= 0 (count #t (remove-duplicates 
                                   (map equal-to-vowel? L)))) 1
   (count #t (remove-duplicates 
                                   (map equal-to-vowel? L)))))

(define (equal-to-vowel? letter)
  (or (equal? 'a letter)
      (equal? 'e letter)
      (equal? 'i letter)
      (equal? 'o letter)
      (equal? 'u letter)
      (equal? 'y letter)))

(define (remove-duplicates L)
  (cond ((null? L) '())
        ((null? (cdr L)) L)
        ((equal? (first L) (second L)) (remove-duplicates (cdr L)))
        (else (cons (first L) (remove-duplicates (cdr L))))) )

;;;;;;The syllable-distributing function and it's sub-functions


(define (syl-dist lists syl)
  (syl-finisher (syl-evener lists syl) (- syl (*
                                         (truncate (/ syl (length lists)))
                                         (length lists))) ))
(define (cons-1 L)
  (cons '1 L))

(define (cons-2 L)
  (cons '2 L))

(define (cons-3 L)
  (cons '3 L))

(define (cons-4 L)
  (cons '4 L))

(define (cons-5 L)
  (cons '5 L))

(define (cons-6 L)
  (cons '6 L))

(define (cons-7 L)
  (cons '7 L))

(define (syl-evener lists syl)
  (cond ((< syl (length lists)) 'more-words-than-syllables!)
        ((= syl (length lists)) (map cons-1 lists))
        ((= 1 (truncate (/ syl (length lists)))) (map cons-1 lists))
        ((= 2 (truncate (/ syl (length lists)))) (map cons-2 lists))
        ((= 3 (truncate (/ syl (length lists)))) (map cons-3 lists))
        ((= 4 (truncate (/ syl (length lists)))) (map cons-4 lists))
        ((= 5 (truncate (/ syl (length lists)))) (map cons-5 lists))
        ((= 6 (truncate (/ syl (length lists)))) (map cons-6 lists))
        ((= 7 (truncate (/ syl (length lists)))) (map cons-7 lists))
        (else 'unexpected-error-in-syl-evener)))

(define (syl-finisher lists syl-remaining)
  (let ( (random-phrase (pick-random lists) ) )
    (replace* random-phrase 
             (cons (+ syl-remaining (car random-phrase)) (cdr random-phrase)) 
             lists)))

;;;;;;The gerund fucntion and it's sub-functions

(define (gerund symbol-word)
  (if (contains? '_
                 (explode symbol-word))
      (gerund (pick-for (syllables symbol-word) verbs))
      (make-gerund symbol-word)))
  
  
(define (make-gerund symbol)
  (string->symbol (add-ing (modify-ing (delete-ending "e" (symbol->string symbol))))))

(define (modify-ing string-word)
  (let* ((char-list (string->list string-word))
        (last-char (last char-list)))
    (if (or (equal? last-char #b)
            (equal? last-char #d)
            (equal? last-char #m)
            (equal? last-char #n)
            (equal? last-char #p)
            (equal? last-char #r))
        (double-last string-word) string-word)))

(define (double-last string-word)
  (let* ((char-list (string->list string-word))
        (last-char (last char-list)))
    (list->string (reverse (cons last-char (reverse char-list))))))
    
(define (delete-ending string-ending string-word)
  (if (eqv? (car (string->list string-ending)) 
            (car (reverse (string->list string-word))))
      (list->string (reverse (cdr (reverse (string->list string-word)))))
      string-word))

(define (add-ing string-word)
(list->string (reverse (cons #g (cons #n (cons #i 
(reverse (string->list string-word))))))))



Was This Post Helpful? 0
  • +
  • -

Page 1 of 1