Lisptran source code
(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))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment