Lisptran source code

gistfile1.txt

(defun multiple (a b)
  "Is A a multiple of B?"
  (= (mod a b) 0))

(defun next-fraction (n fractions)
  "Returns the next value of F in the Fractran program."
  (find-if (lambda (f)
             (integerp (* n f)))
           fractions))

(defun print-fractran-alphabet (n chars)
  "After moving to state N, print all of the necessary characters."
  (loop for (char . number) in chars
        when (multiple n number)
          do (princ char)))

(defun run-fractran (fractions alphabet &optional (n 2))
  "Run the given Fractran program. ALPHABET is an alist of characters to numbers
   representing the alphabet."
  (let ((f (next-fraction n fractions)))
    (if (null f)
        nil
        (let ((next (* n f)))
          (print-fractran-alphabet next alphabet)
          (run-fractran fractions alphabet next)))))

(defun prime (n)
  "Is N a prime number?"
  (loop for i from 2 to (isqrt n)
        never (multiple n i)))

(defparameter *next-new-prime* nil)

(defun new-prime ()
  "Returns a new prime we haven't used yet."
  (prog1 *next-new-prime*
    (setf *next-new-prime*
          (loop for i from (+ *next-new-prime* 1)
                if (prime i)
                  return i))))

(defparameter *cur-inst-prime* nil)
(defparameter *next-inst-prime* nil)

(defun advance ()
  (setf *cur-inst-prime* *next-inst-prime*
        *next-inst-prime* (new-prime)))

(defparameter *lisptran-labels* nil)

(defun prime-for-label (label)
  (or (gethash label *lisptran-labels*)
      (setf (gethash label *lisptran-labels*)
            (new-prime))))

(defparameter *lisptran-macros* (make-hash-table))

(defmacro deftran (name args &body body)
  "Define a Lisptran macro."
  `(setf (gethash ',name *lisptran-macros*)
         (lambda ,args ,@body)))

(defparameter *lisptran-vars* nil)

(defun prime-for-var (var)
  (or (gethash var *lisptran-vars*)
      (setf (gethash var *lisptran-vars*)
            (new-prime))))

(defun assemble (insts)
  "Compile the given Lisptran program into Fractran. Returns two values. the
   first is the Fractran program and the second is the alphabet of the program."
  (let* ((*next-new-prime* 2)
         (*cur-inst-prime* (new-prime))
         (*next-inst-prime* (new-prime))
         (*lisptran-labels* (make-hash-table))
         (*lisptran-vars* (make-hash-table)))
    (values (assemble-helper insts)
            (alphabet *lisptran-vars*))))

(defun alphabet (vars)
  "Given a hash-table of the Lisptran variables to primes, returns an alist
   representing the alphabet."
  (loop for var being the hash-keys in vars
        using (hash-value prime)
        if (characterp var)
          collect (cons var prime)))

(defun assemble-helper (insts)
  (if (null insts)
      '()
      (let ((inst (car insts))
            (rest (cdr insts)))
        (cond
          ;; If it's a number, we just add it to the Fractran program and
          ;; compile the rest of the Lisptran program
          ((numberp inst)
           (cons inst (assemble-helper rest)))
          ;; If it's a symbol, we divide the prime for the next instruction by
          ;; the prime for the label and continue compiling the Lisptran program
          ((symbolp inst)
           (cons (/ *cur-inst-prime* (prime-for-label inst))
                 (assemble-helper rest)))
          ;; Otherwise it's a macro. We look up the function for the macro call
          ;; it on the rest of the instruction. We then append all of the
          ;; instructions returned by it to the rest of the program and compile
          ;; that.
          (:else
           (let ((macrofn (gethash (car inst)
                                   *lisptran-macros*)))
             (assemble-helper (append (apply macrofn
                                             (cdr inst))
                                      rest))))))))

(defun run-lisptran (insts)
  "Run the given Lisptran program."
  (multiple-value-call #'run-fractran (assemble insts)))

(deftran addi (x y)
  (prog1 (list (/ (* *next-inst-prime*
                     (expt (prime-for-var x) y))
                  *cur-inst-prime*))
    (advance)))
    
(deftran subi (x y) `((addi ,x ,(- y))))

(deftran >=i (var val label)
  (prog1 (let ((restore (new-prime)))
           (list (/ restore
                    (expt (prime-for-var var) val)
                    *cur-inst-prime*)
                 (/ (* (prime-for-label label)
                       (expt (prime-for-var var) val))
                    restore)
                 (/ *next-inst-prime* *cur-inst-prime*)))
    (advance)))

(deftran goto (label) `((>=i ,(gensym) 0 ,label)))

(deftran <=i (var val label)
  (let ((skip (gensym)))
    `((>=i ,var ,(+ val 1) ,skip)
      (goto ,label)
      ,skip)))

(deftran print-char (char)
  `((addi ,char 1)
    (subi ,char 1)))

(deftran print-string (str)
  (loop for char across str
        collect `(print-char ,char) into result
        finally (return `(,@result (print-char #\newline)))))

(deftran print-digit (var)
  (loop with gend = (gensym)
        for i from 0 to 9
        for gprint = (gensym)
        for gskip = (gensym)
        append `((<=i ,var ,i ,gprint)
                 (goto ,gskip)
                 ,gprint
                 (print-char ,(digit-char i))
                 (goto ,gend)
                 ,gskip)
        into result
        finally (return `(,@result ,gend))))

(deftran while (test &rest body)
  (let ((gstart (gensym))
        (gend (gensym)))
    `((goto ,gend)
      ,gstart
      ,@body
      ,gend
      (,@test ,gstart))))

(deftran zero (var)
  `((while (>=i ,var 1)
      (subi ,var 1))))

(deftran move (to from)
  (let ((gtemp (gensym)))
    `((zero ,to)
      (while (>=i ,from 1)
        (addi ,gtemp 1)
        (subi ,from 1))
      (while (>=i ,gtemp 1)
        (addi ,to 1)
        (addi ,from 1)
        (subi ,gtemp 1)))))

(deftran modi (var val)
  `((while (>=i ,var ,val)
      (subi ,var ,val))))

(deftran divi (var val)
  (let ((gresult (gensym)))
    `((zero ,gresult)
      (while (>=i ,var ,val)
        (subi ,var ,val)
        (addi ,gresult 1))
      (move ,var ,gresult))))

(deftran print-number (var)
  (let ((gtemp (gensym))
        (gskip (gensym)))
    `((move ,gtemp ,var)
      (divi ,gtemp 10)
      (<=i ,gtemp 0 ,gskip)
      (print-digit ,gtemp)
      ,gskip
      (move ,gtemp ,var)
      (modi ,gtemp 10)
      (print-digit ,gtemp)
      (print-char #\newline))))

((move x 1)
 (while (<=i x 100)
   (move rem x)
   (modi rem 15)
   (<=i rem 0 fizzbuzz)

   (move rem x)
   (modi rem 3)
   (<=i rem 0 fizz)

   (move rem x)
   (modi rem 5)
   (<=i rem 0 buzz)

   (print-number x)
   (goto end)

   fizzbuzz
   (print-string "fizzbuzz")
   (goto end)

   fizz
   (print-string "fizz")
   (goto end)

   buzz
   (print-string "buzz")
   (goto end)

   end
   (addi x 1)))