#!/usr/local/bin/kalypso
#
# lfact
#
# arbitrary precision factorial in lisp
#
# Note that this contains three useful routines
# add-big-unsigned, sub-big-unsigned mult-big-unsigned
# which may be useful in future calculators!
#

(setq max-digit 10000)

(defun add-big-unsigned (a b carry)
  (cond ((and (not a) (not b))
	 (cond ((= 0 carry)
		nil
		)
	       (t (list carry))
	       )
	 )
	(t (let ((result (+ (cond (a (car a))
		     	      	  (t 0)
		     	      	  )
	       	       	    (cond (b (car b))
		     	      	  (t 0)
		     	      	  )
			    carry
		       	    )
		       	 )
	       	 )
	     (cons (mod result max-digit)
	      	   (add-big-unsigned (cond (a (cdr a))
				      	   (t nil)
				      	   )
				     (cond (b (cdr b))
				      	   (t nil)
				      	   )
				     (div result max-digit)
				     )
		   )
	     )
	   )
	)
  )

(defun mult-one-unsigned (digit number carry)
  (cond (number
	 (let ((result (+ (* digit (car number)) carry)))
	       (cons (mod result max-digit)
		     (mult-one-unsigned digit
					(cdr number)
					(div result max-digit)
					)
		     )
	   )
	 )
	((= 0 carry) nil)
	(t (list carry))
	)
  )

(defun mult-big-unsigned (a b)
  (cond (a
	 (add-big-unsigned (mult-one-unsigned (car a) b 0)
			   (let ((result (mult-big-unsigned (cdr a) b)))
			     (cond (result
				    (cons 0 result)
				    )
				   (t nil)
				   )
			     )
			   0
			   )
	 )
	(t nil)
	)
  )

(defun sub-big-unsigned (a b carry)
  (cond ((and (not a) (not b))
	 (cond ((= 0 carry)
		nil
		)
	       (t (list carry))
	       )
	 )
	(t (let ((result (- (cond (a (car a))
		     	      	  (t 0)
		     	      	  )
	       	       	    (cond (b (car b))
		     	      	  (t 0)
		     	      	  )
			    carry
		       	    )
		       	 )
		 (rest)
		 )
	     (setq rest (sub-big-unsigned (cond (a (cdr a))
				      	   	(t nil)
				      	   	)
				     	  (cond (b (cdr b))
				      	   	(t nil)
				      	   	)
				     	  (cond ((< result 0)
					    	 1
					    	 )
					   	(t 0)
					   	)
				     	  )
		   )
	     (cond (rest
		    (cons (mod result max-digit rest))
		    )
		   ((= 0 result)
		    nil)
		   (t (list result))
		   )
	     )
	   )
	)
  )

(defun fact-big (a)
  (cond (a
	 (mult-big-unsigned a (fact-big (sub-big-unsigned a '(1) 0)))
	 )
	(t '(1))
	)
  )

(defun print-n-digits (x n)
  (cond ((= 0 n)
	 nil
	 )
	(t (patom (div x (pow 10 (1- n))))
	   (print-n-digits (mod x (pow 10 (1- n))) (1- n))
	   )
	)
  )

(defun print-big-unsigned (a)
  (cond (a
	 (cond ((cdr a)
	 	(print-big-unsigned (cdr a))
	 	(print-n-digits (car a) (log10 max-digit))
		)
	       (t (patom a))
	       )
	 )
	(t nil)
	)
  )

(defun ungetchar (c)
  (fungetchar stdin c)
  )

(defun read-digits ()
  (let ((c (getchar)))
    (cond ((null? c) (throw 'done))
	  ((and (<= ~0 c) (<= c ~9))
	   (cons (- c ~0) (read-digits))
	   )
	  (t (ungetchar c) nil)
	  )
    )
  )

(defun read-white ()
  (let ((c (getchar)))
    (cond ((null? c) (throw 'done))
	  ((or (= c ~ ) (= c ~\t) (= c ~\n)) (read-white))
	  (t (ungetchar c))
	  )
    )
  )
    
(defun strip-digits (num-digits)
  (cond (digits
	 (cond ((= 0 num-digits)
		0
		)
	       (t (+ (car digits) (* (prog ()
				       (setq digits (cdr digits))
				       (strip-digits (- num-digits 1))
				       )
				     10
				     )
		     )
		  )
	       )
	 )
	(t 0)
	)
  )

(defun convert-to-base (digits num-digits)
  (cond (digits
  	 (let ((dig (strip-digits num-digits)) (rest))
	   (setq rest (convert-to-base digits num-digits))
	   (cond (rest
		  (cons dig rest)
		  )
		 (t (cond ((= 0 dig) nil)
			  (t (list dig))
			  )
		    )
		 )
	   )
	 )
	(t nil)
	)
  )

(defun read-big-unsigned ()
  (read-white)
  (convert-to-base (reverse (read-digits)) (log10 max-digit))
  )

(defun read-print-fact ()
  (let ((num))
    (catch (while t
		  (setq num (read-big-unsigned))
       	   	  (print-big-unsigned (fact-big num))
	   	  (terpr)
       	   	  )
	   done
	   )
    t
    )
  )

(read-print-fact)
