Scheme program to calculate the amount of dog names we could shove in a database.

roman-dogs.scm

(import (scheme base)
		(scheme case-lambda)
		(scheme file)
		(scheme lazy)
		(scheme write))

(define (filter pred lst)
  (cond ((null? lst)
		 '())
		((pred (car lst))
		 (cons (car lst)
			   (filter pred
					   (cdr lst))))
		(else
		 (filter pred
				 (cdr lst)))))

(define (merge-sort-list lst before?)
  (define (merge a b)
	(cond ((null? a)
		   b)
		  ((null? b)
		   a)
		  ((before? (car b)
					(car a))
		   (cons (car b)
				 (merge a
						(cdr b))))
		  (else
		   (cons (car a)
				 (merge (cdr a)
						b)))))

  (define (merge-pass lists)
	(if (or (null? lists)
			(null? (cdr lists)))
		lists
		(cons (merge (car lists)
					 (cadr lists))
			  (merge-pass (cddr lists)))))

  (cond ((not (list? lst))
		 (error "LST is not a list"
				lst))
		((null? lst)
		 lst)
		(else
		 (let loop ((lst (map list lst)))
		   (if (null? (cdr lst))
			   (car lst)
			   (loop (merge-pass lst)))))))

(define (drop-end lst n)
  (let loop ((lst lst)
			 (return (lambda (res n)
					   res)))
	(if (null? lst)
		(return '() n)
		(loop (cdr lst)
			  (lambda (res n)
				(if (> n 0)
					(return res
							(- n 1))
					(return (cons (car lst)
								  res)
							n)))))))

(define (last-before x lst before?)
  (let loop ((last #f)
			 (lst lst))
	(if (or (null? lst)
			(not (before? (car lst)
						  x)))
		last
		(loop (car lst)
			  (cdr lst)))))

;;; Streams.

(define-record-type <stream>
  (make-stream promise)
  stream?
  (promise stream-promise))

(define stream-null
  (make-stream (delay '())))

(define (stream-force strm)
  (let ((obj (force (stream-promise strm))))
	(if (stream? obj)
		(stream-force obj)
		obj)))

(define (stream-null? obj)
  (and (stream? obj)
	   (null? (stream-force obj))))

(define (stream-pair? obj)
  (and (stream? obj)
	   (pair? (stream-force obj))))

(define-syntax stream-cons
  (syntax-rules ()
	((_ obj1 obj2)
	 (make-stream (delay (cons obj1 obj2))))))

(define (stream-car strm)
  (car (stream-force strm)))

(define (stream-cdr strm)
  (cdr (stream-force strm)))

(define-syntax stream-lambda
  (syntax-rules ()
	((_ formals exp body ...)
	 (lambda formals
	   (make-stream
		(delay (begin exp body ...)))))))

(define-syntax define-stream
  (syntax-rules ()
	((_ (name args ...) body ...)
	 (define name
	   (stream-lambda (args ...)
					  body ...)))))

(define stream->list
  (case-lambda
	((strm)
	 (let loop ((strm strm))
	   (if (stream-null? strm)
		   '()
		   (cons (stream-car strm)
				 (loop (stream-cdr strm))))))
	((n strm)
	 (let loop ((n n)
				(strm strm))
	   (if (or (zero? n)
			   (stream-null? strm))
		   '()
		   (cons (stream-car strm)
				 (loop (- n 1)
					   (stream-cdr strm))))))))

(define (stream-append strm . strms)
  (define-stream (sa-aux strms)
	(cond ((null? (cdr strms))
		   (car strms))
		  ((stream-null? (car strms))
		   (sa-aux (cdr strms)))
		  (else
		   (stream-cons (stream-car (car strms))
						(cons (stream-cdr (car strms))
							  (cdr strms))))))

  (sa-aux (cons strm strms)))

(define (stream-drop n strm)
  (cond ((stream-null? strm)
		 stream-null)
		((zero? n)
		 strm)
		(else
		 (stream-drop (- n 1)
					  (stream-cdr strm)))))

(define (stream-ref strm k)
  (stream-car (stream-drop k strm)))

(define-stream (stream-take n strm)
  (if (or (zero? n)
		  (stream-null? strm))
	  stream-null
	  (stream-cons (stream-car strm)
				   (stream-take (- n 1)
								(stream-cdr strm)))))

(define-stream (stream-take-while pred strm)
  (if (or (stream-null? strm)
		  (not (pred (stream-car strm))))
	  stream-null
	  (stream-cons (stream-car strm)
				   (stream-take-while pred
									  (stream-cdr strm)))))

;;; Numerals.

(define (make-roman-numeral symbol value)
  (cons symbol value))

(define (roman-numeral-symbol numeral)
  (car numeral))

(define (roman-numeral-value numeral)
  (cdr numeral))

(define (roman-numeral< a b)
  (< (roman-numeral-value a)
	 (roman-numeral-value b)))

(define (roman-numeral> a b)
  (roman-numeral< b a))

(define (roman-numeral= a b)
  (= (roman-numeral-value a)
	 (roman-numeral-value b)))

(define (roman-numeral<= a b)
  (or (roman-numeral< a b)
	  (roman-numeral= a b)))

(define (roman-numeral>= a b)
  (roman-numeral<= b a))

(define (prefix-roman-numerals minor major)
  (make-roman-numeral (string-append (roman-numeral-symbol minor)
									 (roman-numeral-symbol major))
					  (- (roman-numeral-value major)
						 (roman-numeral-value minor))))

(define (prefix-roman-numeral-lists minors majors)
  (let loop ((minors minors)
			 (majors majors))
	(if (or (null? minors)
			(null? majors))
		'()
		(let ((minor (car minors)))
		  (if (roman-numeral<= (car majors)
				  minor)
			  (loop minors
					(cdr majors))
			  (let do-prefix ((rest majors))
				(if (null? rest)
					(loop (cdr minors)
						  majors)
					(cons (prefix-roman-numerals minor
												(car rest))
						  (do-prefix (cdr rest))))))))))

(define (add-roman-numerals major minor)
  (make-roman-numeral (string-append (roman-numeral-symbol major)
									 (roman-numeral-symbol minor))
					  (+ (roman-numeral-value major)
						 (roman-numeral-value minor))))

;;; Trees.

(define make-numeral-tree
  (case-lambda
	((tens fives)
	 (make-numeral-tree tens fives '() '() '() '()))
	((tens fives nines fours)
	 (make-numeral-tree tens fives nines fours '() '()))
	((tens fives nines fours eights threes)
	 (list->vector
	  (map (lambda (numerals)
			 (merge-sort-list numerals roman-numeral<))
		   (list tens fives nines fours eights threes))))))

(define (make-basic-numeral-tree tens fives)
  (make-numeral-tree tens fives))

(define (numeral-tree-tens tree)
  (vector-ref tree 0))

(define (numeral-tree-fives tree)
  (vector-ref tree 1))

(define (numeral-tree-nines tree)
  (vector-ref tree 2))

(define (numeral-tree-fours tree)
  (vector-ref tree 3))

(define (numeral-tree-eights tree)
  (vector-ref tree 4))

(define (numeral-tree-threes tree)
  (vector-ref tree 5))

(define basic-ascii-tree
  (make-basic-numeral-tree
   (list (make-roman-numeral "I" 1)
		 (make-roman-numeral "X" 10)
		 (make-roman-numeral "C" 100)
		 (make-roman-numeral "M" 1000))
   (list (make-roman-numeral "V" 5)
		 (make-roman-numeral "L" 50)
		 (make-roman-numeral "D" 500))))

(define basic-unicode-tree
  (make-basic-numeral-tree
   (list (make-roman-numeral "ↈ" 100000)
		 (make-roman-numeral "ↂ" 10000)
		 (make-roman-numeral "Ⅿ" 1000)
		 (make-roman-numeral "Ⅽ" 100)
		 (make-roman-numeral "Ⅹ" 10)
		 (make-roman-numeral "Ⅰ" 1))
   (list (make-roman-numeral "ↇ" 50000)
		 (make-roman-numeral "ↁ" 5000)
		 (make-roman-numeral "Ⅾ" 500)
		 (make-roman-numeral "Ⅼ" 50)
		 (make-roman-numeral "Ⅴ" 5))))

;;; Long numerals.
;; Counting to 10:
;; I II III IV V VI VII VIII IX X.
;; 778:
;; DCCLXXVIII.
;; 1999:
;; MCMXCIX.

(define (make-long-roman-tree basic-tree)
  (let ((tens (numeral-tree-tens basic-tree))
		(fives (numeral-tree-fives basic-tree)))
	(let ((thead (drop-end tens 1)))
	  (make-numeral-tree tens
						 fives
						 (map prefix-roman-numerals
							  thead
							  (cdr tens))
						 (map prefix-roman-numerals thead fives)))))

(define long-ascii-tree
  (make-long-roman-tree basic-ascii-tree))

(define long-unicode-tree
  (make-long-roman-tree basic-unicode-tree))

;;; Short numerals.
;; Counting to 10:
;; I II III IV V VI VII VIII IX X.
;; 778:
;; DCCLXXVIII.
;; 1999:
;; IM.

(define (make-short-roman-tree basic-tree)
  (let ((tens (numeral-tree-tens basic-tree))
		(fives (numeral-tree-fives basic-tree)))
	(make-numeral-tree tens
					   fives
					   (prefix-roman-numeral-lists tens tens)
					   (prefix-roman-numeral-lists tens fives))))

(define short-ascii-tree
  (make-short-roman-tree basic-ascii-tree))

(define short-unicode-tree
  (make-short-roman-tree basic-unicode-tree))

;;; Long Parker numerals:
;; Counting to 10:
;; I II IIV IV V VI VII IIX IX X.
;; 778:
;; DCCLXXIIX.
;; 1999:
;; MCMXCIX.

(define (make-long-parker-roman-tree long-tree)
  (let ((tens (numeral-tree-tens long-tree))
		(fives (numeral-tree-fives long-tree))
		(nines (numeral-tree-nines long-tree))
		(fours (numeral-tree-fours long-tree)))
	(let ((thead (drop-end tens 1)))
	  (make-numeral-tree tens
						 fives
						 nines
						 fours
						 (map prefix-roman-numerals thead nines)
						 (map prefix-roman-numerals thead fours)))))

(define long-parker-ascii-tree
  (make-long-parker-roman-tree long-ascii-tree))

(define long-parker-unicode-tree
  (make-long-parker-roman-tree long-unicode-tree))

;;; Short Parker numerals:
;; Counting to 10:
;; I II IIV IV V VI VII IIX IX X.
;; 778:
;; IIXXCCM.
;; 1999:
;; IM.

(define (make-short-parker-roman-tree long-tree)
  (let ((tens (numeral-tree-tens long-tree))
		(fives (numeral-tree-fives long-tree))
		(nines (numeral-tree-nines long-tree))
		(fours (numeral-tree-fours long-tree)))
	(make-numeral-tree tens
					   fives
					   (prefix-roman-numeral-lists tens tens)
					   (prefix-roman-numeral-lists tens fives)
					   (prefix-roman-numeral-lists tens nines)
					   (prefix-roman-numeral-lists tens fours))))

(define short-parker-ascii-tree
  (make-short-parker-roman-tree long-ascii-tree))

(define short-parker-unicode-tree
  (make-short-parker-roman-tree long-unicode-tree))

;;; Streaming numerals.

(define (make-numeral-stream tree)
  (let ((tens (numeral-tree-tens tree))
		(nines (numeral-tree-nines tree))
		(eights (numeral-tree-eights tree))
		(fives (numeral-tree-fives tree))
		(fours (numeral-tree-fours tree))
		(threes (numeral-tree-threes tree)))
	(let ((numerals (merge-sort-list (append tens
											 nines
											 eights
											 fives
											 fours
											 threes)
									 roman-numeral<)))
	  (define (make-numeral n)
		(let ((rn (last-before (make-roman-numeral "" n)
							   numerals
							   roman-numeral<=)))
		  (cond ((not rn)
				 (make-roman-numeral "" n))
				((= (roman-numeral-value rn)
					n)
				 rn)
				(else
				 (add-roman-numerals rn
									 (make-numeral
									  (- n
										 (roman-numeral-value rn))))))))

	  (define-stream (numeral-stream n)
		(stream-cons (make-numeral n)
					 (numeral-stream (+ n 1))))

	  (numeral-stream 1))))

;; 1609 elements.
(define short-parker-ascii-dogs
  (stream->list
   (stream-filter (lambda (rn)
					(<= (string-length (roman-numeral-symbol rn))
						6))
				  (stream-take
				   (* 6
					  (roman-numeral-value
					   (car
						(merge-sort-list
						 (numeral-tree-tens basic-ascii-tree)
						 roman-numeral>))))
				   (make-numeral-stream short-parker-ascii-tree)))))

;; 17958 elements.
(define short-parker-unicode-dogs
  (stream->list
   (stream-filter (lambda (rn)
					(<= (string-length (roman-numeral-symbol rn))
						6))
				  (stream-take
				   (* 6
					  (roman-numeral-value
					   (car
						(merge-sort-list
						 (numeral-tree-tens basic-unicode-tree)
						 roman-numeral>))))
				   (make-numeral-stream short-parker-unicode-tree)))))

(with-output-to-file "short-parker-ascii-dogs.txt"
  (lambda ()
	(for-each (lambda (n)
				(display (roman-numeral-symbol n))
				(newline))
			  short-parker-ascii-dogs)))

(with-output-to-file "short-parker-unicode-dogs.txt"
  (lambda ()
	(for-each (lambda (n)
				(display (roman-numeral-symbol n))
				(newline))
			  short-parker-unicode-dogs)))