scheme-test-programs/logic/t-names.scm

;; import functions/repeat.scm numbers/linear-random.scm files/words.scm

(define (assoc-all-cdr x xs)
  (let loop ((xs xs) (memo '()) (size 0))
    (if (null? xs)
        (cons memo size)
        (let ((f (car xs))
              (r (cdr xs))
              (size^ (+ size 1)))
          (if (eq? (car f) x)
              (loop r (cons (cdr f) memo) size^)
              (loop r memo size))))))

(define (random-car table.size)
  (let* ((table (car table.size))
         (size (cdr table.size))
         (rand (modulo (random!) size)))
    (car (list-ref table rand))))


(define (iter table p2 p1 memo)
  (let* ((table.size1 (assoc-all-cdr p2 table))
         (table1 (car table.size1))
         (table.size2 (assoc-all-cdr p1 table1))
         (next (random-car table.size2)))
    (if (null? next)
        (reverse memo)
        (iter table p1 next (cons next memo)))))

(define (name! source table.size min)
  (let* ((table (car table.size))
         (first-letter (random-car source))
         (table.size1 (assoc-all-cdr first-letter table))
         (second-letter (random-car table.size1))
         (name (iter table first-letter second-letter (list second-letter first-letter))))
    (if (>= (length name) min)
        (list->string name)
        (name! source table.size min))))

(define (build-names table.size file)
  (let ((letter-2 #f)
        (letter-1 #f)
        (first-letters '())
        (size 0))
    (for-each (lambda (word)
                (let ((word (string->list word)))
                  (cond ((< 2 (length word))
                         (set! first-letters (cons (list (car word)) first-letters))
                         (set! size (+ 1 size))
                         (set! letter-2 (car word))
                         (set! letter-1 (cadr word))
                         (set! word (cddr word))
                         (for-each
                          (lambda (letter)
                            (set-cdr! table.size (+ 1 (cdr table.size)))
                            (set-car! table.size (cons (list letter-2 letter-1 letter) (car table.size)))
                            (set! letter-2 letter-1)
                            (set! letter-1 letter))
                          word)
                         (set-cdr! table.size (+ 1 (cdr table.size)))
                         (set-car! table.size (cons (list letter-2 letter-1 '()) (car table.size)))))))
              (with-input-from-file file words))
    (cons first-letters size)))

(define names (cons '() 0))
(define surnames (cons '() 0))
(define names-source (build-names names "data/finnish_firstnames.txt"))
(define surnames-source (build-names surnames "data/finnish_lastname.txt"))

(repeat
 (lambda ()
   (display (name! names-source names 2)) (display " ")
   (display (name! surnames-source surnames 5)) (newline))
 100)