From sunybcs!lammens Mon Apr  2 17:26:22 EDT 1990
Article 24 of sunyab.cs.676:
Path: sunybcs!lammens
>From: lammens@acsu.Buffalo.EDU (Joe Lammens)
Newsgroups: sunyab.cs.676
Subject: Universal program
Date: 2 Apr 90 18:13:17 GMT
Sender: nobody@acsu.Buffalo.EDU
Distribution: local
Lines: 511

Last Thursday (03/29) we briefly discussed universal programs, and
what they do to descriptions of other programs (you can substitute
Turing Machine" for "program" if you like).

If you're interested in the subject, and are somewhat familiar with
theory of computation, you might find the lisp program below
interesting to experiment with. It's a lisp implementation of a
universal program that takes numbers as input and interprets them as
programs, and some related functions. The code has all the
documentation you need. 

Cut between the ----CUT HERE---- lines (there's one at the end too!),
save to a file and load the file into any Common Lisp interpreter. The
code has some on-line examples. Enjoy.

----CUT HERE---- 

;;;---------------------------------------------------------------------------
;;;
;;; universal.lisp
;;;
;;; Joe Lammens 10/26/89
;;; SUNY/Buffalo dept. of Computer Science, Buffalo NY 14260
;;; e-mail lammens@cs.buffalo.edu
;;;
;;; Feel free to distribute.
;;;
;;; Revised 03/31/90 to use inc, dec, bnz in stead of increment,
;;; decrement, branch-on-not-zero as mnemonic instruction names.
;;; 
;;; This file contains some functions for coding, decoding and executing
;;; programs (or their corresponding numbers) of the language L as
;;; defined in Martin D. Davis & Elaine J. Weyuker, "Computability,
;;; Complexity and Languages", Academic Press, New York etc. 1983,
;;; chapters 2-4. The syntax is Common Lisp, as defined in Guy L. Steele
;;; jr., "Common Lisp", Digital Press, Bedford MA 1984. Since this stuff
;;; is meant for educational use or just for fun, it is not optimized
;;; for efficiency. Efficiency is not a consideration with a language
;;; like L anyway. But I suspect functions like next-bigger-prime could
;;; be optimized quite a bit. Load the complete file into a Common Lisp
;;; system and enjoy. A couple of example calls are included near the
;;; end of the file.
;;;
;;;---------------------------------------------------------------------------
;;;
;;; All functions work with integer numbers or L-programs in list format,
;;; which is a list of instructions. Common Lisp in principle allows integers
;;; of any magnitude, although (de)coding big L-programs might take a while or
;;; might cause the interpreter to run out of memory. Each instruction is a
;;; list of four symbols (<label> <statement> <variable> <goto-label>). A
;;; <label> is either NIL or one of the letters (A B C D E) in upper or lower
;;; case followed by a positive integer, e.g. A1, B2, E4567. A <statement> is
;;; one of the symbols (NOP INC DEC BNZ),
;;; corresponding to the L statements V <- V, V <- V + 1, V <- V - 1, and IF V
;;; =/= 0 GOTO L, respectively. A <variable> is either the single letter Y or
;;; one of the letters (X Z) followed by a positive integer, e.g.  X1, Z34. A
;;; <goto-label> has the same syntax as a <label>. An example of an
;;; instruction is (A1 INC X1 NIL). An example of a program is ((A1
;;; INC X1 NIL) (NIL BNZ X1 A1)), which is the program
;;; that computes the nowhere defined function of D&W Ch4 sec1. The list
;;; format is chosen to simplify processing of the program and to avoid having
;;; to build a lexical analyzer, although it should not be too hard to add
;;; one. Since the statements are implemented as separate functions (with the
;;; exception of the branch statement), macros can be defined by defining a
;;; new function and using its name as a <statement> in a program.  Each
;;; instruction must have at least the four specified elements, but more may
;;; be added to the end of the instruction list. All symbols after the
;;; <statement> are passed to the function implementing the <statement> as a
;;; list. See the code for more details. No significant error checking is done
;;; on the program syntax, so be sure to specify it correctly (or, think of
;;; a number that will do the job and have it decoded :-)).
;;;
;;;---------------------------------------------------------------------------
;;;
;;; The following is a short description of the top-level functions with their
;;; arguments, in Steele's style. Every defined function has a documentation
;;; string that can be retrieved by evaluating (documentation '<function-name>
;;; 'function).
;;;
;;; encode-program program
;;; 
;;;   encodes program and returns its integer number
;;;
;;; decode-program-number program-number
;;; 
;;;   decodes program-number and returns the corresponding program
;;;
;;; enumerate-programs-from-to from to &key :print :return-list
;;; 
;;;   decodes all programs with numbers in the interval [from,to]. 
;;;   if :print is t (default nil), prints them on standard output 
;;;   if :return-list is t (default t), returns a list of the programs, else
;;;   returns nil
;;;
;;; execute-program program &key :input-values :trace
;;; 
;;;   executes program and returns the value of Y after termination (if the
;;;   program terminates at all!).
;;;   if :input-values is a list of integers (default nil), they are assigned
;;;   to the variables X1, X2,... in order before execution of the program
;;;   if :trace is t (default nil), prints the current bindings of all
;;;   variables and the current instruction on standard output at the
;;;   beginning of each read and execute cycle. 
;;;
;;; execute-program-number program-number &key :input-values :trace
;;; 
;;;   like execute-program, but takes a program number and decodes it into a
;;;   program before executing it. This is in fact a lisp implementation of
;;;   the universal program for L-programs, but of course one may define the
;;;   universal program in L itself, and feed its number to this function.
;;;
;;;---------------------------------------------------------------------------



;;;---------------------------------------------------------------------------
;;;
;;; Top level functions 
;;;
;;;---------------------------------------------------------------------------



(defun encode-program (program)
  "Encodes program and returns the program number."
  (encode-instruction-number-list (mapcar #'encode-instruction program))
  )


(defun decode-program-number (program-number)
  "Decodes program-number into a program and returns the program."
  (decode-instruction-number-list (prime-factorize (+ program-number 1)))
  )


(defun enumerate-programs-from-to (from to &key (print nil) (return-list t))
  "Decodes all programs whose number is in the interval [from,to].
   If :print is non-nil prints the programs on standard output.
   If :return-list is non-nil returns a list of the programs, else nil."
  (let ((program nil)
	(result nil))
    (do ((number from (1+ number)))
	((> number to) (when print (format t "~%~%")) result)
      (setq program (decode-program-number number))
      (when return-list
	(setq result (append result (list program))))
      (when print
	(format t "~%~%Program number ~A:~%~S" number program))
      )
    )
  )


(defvar y)
(defvar x)
(defvar x1)

(defun execute-program (program &key (input-values nil) (trace nil))
  "Executes program. If :input-values is a list of integers, assigns them to
   the program variables X1, X2,... in order before executing the program.
   If :trace is non-nil, prints the current variable bindings and the current
   instruction on standard output at the start of each read and execute cycle.
   Returns the value of the output variable Y after execution."
  (setq y 0)
  (let ((current-instruction (first program))
	(rest-program (rest program))
	(initialized-variables '(y))
	(input-variable-count 0)
	variable-name-string
	)
    ;; initialize input variables 
    (dolist (value input-values)
      (setq input-variable-count (1+ input-variable-count))
      (setq variable-name-string
	    (concatenate 'string "X" (princ-to-string input-variable-count)))
      (eval `(setq ,(read-from-string variable-name-string) ,value))
      (setq initialized-variables
	    (cons (read-from-string variable-name-string)
		  initialized-variables)))
    ;; define x to be a synonym for x1
    (when (member 'x1 initialized-variables) (setq x x1))
    ;; interpretation loop
    (loop
      ;; trace state of computation
      (when trace
	(format t "~%Current bindings:    ~S~%Current instruction: ~S"
		(mapcar #'(lambda (var) (list var (eval var))) initialized-variables)
		current-instruction
		))
      ;; initialize unbound variables to 0
      (when (not (member (third current-instruction) initialized-variables))
	(eval `(setq ,(third current-instruction) 0))
	(setq initialized-variables
	      (cons (third current-instruction) initialized-variables)))
      (cond
	;; check for branch instruction
	((eql (second current-instruction) 'bnz)
	 (if (plusp (eval (third current-instruction)))
	     (setq current-instruction
		   (assoc (fourth current-instruction) program)
		   rest-program
		   (rest (member current-instruction program)))
	     (setq current-instruction (first rest-program)
		   rest-program (rest rest-program))))
	;; else execute the instruction by calling its implementing function
	(t (eval (list (second current-instruction)
		       `(quote ,(rest (rest current-instruction)))))
	   (setq current-instruction (first rest-program)
		 rest-program (rest rest-program))))
      ;; terminating condition
      (when (null current-instruction)
	(return y))
      )						; interpretation loop
    (when trace
	(format t "~%Current bindings:    ~S"
		(mapcar #'(lambda (var) (list var (eval var))) initialized-variables)
		))
    y						; return value of output variable
    )						; let
  )


(defun execute-program-number (program-number &key (input-values nil) (trace nil))
  "Decodes program-number and executes the corresponding program.
   If :input-values is a list of integers, assigns them to the program
   variables X1, X2,... in order before executing the program. If :trace is
   non-nil, prints the current variable bindings and the current instruction on
   standard output at the start of each read and execute cycle. Returns the
   value of the output variable Y after execution." 
  (execute-program (decode-program-number program-number)
		   :input-values input-values :trace trace)
  )


;;;---------------------------------------------------------------------------
;;;
;;; Lower level functions
;;;
;;;---------------------------------------------------------------------------



(defun decode-instruction-number-list (instruction-number-list)
  "Decodes a list of instruction numbers and returns a list of
   instructions."
  (mapcar #'decode-instruction-number instruction-number-list)
  )


(defun decode-instruction-number (instruction-number)
  "Decodes instruction-number and returns a single instruction list."
  (list
    ;; instruction label
    ((lambda (a)
       (cond ((= a 0) nil)
	     (t (read-from-string
		  (concatenate 'string
			       (nth (mod (- a 1) 5) '("A" "B" "C" "D" "E"))
			       (format nil "~A" (+ (floor (- a 1) 5) 1)))))))
     (left instruction-number))
    ;; statement symbol
    ((lambda (b)
       (cond ((<= b 2) (nth b '(nop inc dec)))
	     (t 'bnz)))
     (left (right instruction-number)))
    ;; variable symbol
    ((lambda (c)
       (cond
	 ((= c 0) 'y)
	 (t (read-from-string
	      (concatenate 'string
			   (nth (mod (- c 1) 2) '("X" "Z"))
			   (format nil "~A" (+ (floor (- c 1) 2) 1)))))))
     (right (right instruction-number)))
    ;; GOTO label
    ((lambda (b)
       (cond
	 ((> b 2)
	  (read-from-string
	    (concatenate 'string
			 (nth (mod (- b 3) 5) '("A" "B" "C" "D" "E"))
			 (format nil "~A" (+ (floor (- b 3) 5) 1)))))
	 (t nil)))
     (left (right instruction-number)))
    )
  )


(defun encode-instruction-number-list (instruction-number-list)
  "Encodes a list of instruction numbers as a product of primes and returns the
   resulting number."
  (let ((prime 2)
	(result 1))
    (dolist (instruction-number instruction-number-list)
      (setq result (* result (expt prime instruction-number))
	    prime (next-bigger-prime prime)))
    (1- result))
  )


(defun encode-instruction (instruction)
  "Encodes instruction and returns the resulting number."
  (let* ((label (first instruction))
	 (statement (second instruction))
	 (variable (third instruction))
	 (goto-label (fourth instruction))
	 (a (if label (label-number label) 0))
	 (b (cond
	      ((eql statement 'nop) 0)
	      ((eql statement 'inc) 1)
	      ((eql statement 'dec) 2)
	      ((eql statement 'bnz)
	       (+ (label-number goto-label) 2))
	      (t (format t "~%Unknown statement: ~S" statement)
		 0)))
	 (c (1- (variable-number variable))))
    (pairing-function a (pairing-function b c))
    )
  )


(defun label-number (label)
  "Converts label to a number and returns the number."
  (let* ((string-label (princ-to-string label))
	 (subscript-string
	   (string-left-trim "ABCDEFGHIJKLMNOPQRSTUVWXYZ" string-label))
	 (base-string (string-right-trim "0123456789" string-label))
	 (label-subscript
	   (if (string/= subscript-string "")
	       (read-from-string subscript-string)
	       1))
	 (label-base-number
	   (cond
	     ((string-equal base-string "A") 1)
	     ((string-equal base-string "B") 2)
	     ((string-equal base-string "C") 3)
	     ((string-equal base-string "D") 4)
	     ((string-equal base-string "E") 5)
	     (t (format t "~%Unknown label: ~A" label)
		9999)))
	 )
    (+ label-base-number (* (1- label-subscript) 5))
    )
  )


(defun variable-number (variable)
  "Converts variable to a number and returns the number."
  (let* ((string-variable (princ-to-string variable))
	 (subscript-string
	   (string-left-trim "ABCDEFGHIJKLMNOPQRSTUVWXYZ" string-variable))
	 (base-string (string-right-trim "0123456789" string-variable))
	 (variable-subscript
	   (if (string/= subscript-string "")
	       (read-from-string subscript-string)
	       1))
	 (variable-base-number
	   (cond
	     ((string-equal base-string "Y") 1)
	     ((string-equal base-string "X") 2)
	     ((string-equal base-string "Z") 3)
	     (t (format t "~%Unknown variable: ~A" variable)
		9999)))
	 )
    (+ variable-base-number (* (1- variable-subscript) 2))
    )
  )


(defun pairing-function (x y)
  "Implements the pairing function of D&W ch3 sec8."
  (monus (* (expt 2 x) (1+ (* 2 y))) 1)
  )


(defun monus (x y)
  "Implements the monus function of D&W ch3 sec4."
  (if (minusp (- x y)) 0 (- x y))
  )


(defun left (number)
  "Computes l(number) as in D&W Ch3, sec8."
  (let ((result (floor (log (+ number 1) 2)))
	(number1 (+ number 1)))
    (loop
     (if (= (mod number1 (expt 2 result)) 0)
	 (return result)
       (setq result (- result 1))))
    result)
  )


(defun right (number)
  "Computes r(number) as in D&W Ch3, sec8."
  (floor (- (floor (+ number 1) (expt 2 (left number))) 1) 2)
  )


(defun prime-factorize (number)
  "Factorizes number into a product of integer powers of prime
   numbers, and returns a list of all exponents of the primes from 2 to
   the maximum prime number with a non-zero exponent. See D&W ch3, sec8."
  (let ((prime 2)
	(exponent 0)
	(remainder number)
	(result nil))
    (loop
     (setq exponent
	   (do ((e (ceiling (log remainder prime)) (1- e)))
	       ;; ceiling to prevent roundoff errors!!
	       ((zerop (mod remainder (expt prime e))) e))
	   remainder (floor remainder (expt prime exponent))
	   result (append result (list exponent))
	   prime (next-bigger-prime prime))
     (when (= remainder 1) (return result)))
    result)
  )


(defun next-bigger-prime (prime)
  "Returns the next prime number bigger than prime."
  (let* ((candidate-prime (+ prime 1))
	 (maximum-divisor (isqrt candidate-prime))
	 )
    (loop
     (if (do ((divisor 2 (+ divisor 1)))
	     ((or (= (mod candidate-prime divisor) 0)
		   (> divisor maximum-divisor))
	      (> divisor maximum-divisor)))
	 (return candidate-prime)
       (setq candidate-prime (+ candidate-prime 1)
	     maximum-divisor (isqrt candidate-prime))))
    candidate-prime)
  )



;;;---------------------------------------------------------------------------
;;;
;;; Functions implementing the L language statements - this really defines the
;;; semantics of those statements. Add macro definitions here if wanted.
;;;
;;;---------------------------------------------------------------------------



(defun inc (arguments)
  "Implements the L language increment function."
  (eval `(setq ,(first arguments) (1+ ,(first arguments))))
  )


(defun dec (arguments)
  "Implements the L language decrement function."
  (eval `(when (plusp ,(first arguments))
	       (setq ,(first arguments) (1- ,(first arguments)))))
  )


(defun nop (arguments)
  "Implements the L language nop function."
  nil
  )



;;;---------------------------------------------------------------------------
;;;
;;; Some example calls - will be evaluated when this file is loaded
;;;
;;;---------------------------------------------------------------------------



(format t "~%~%Universal.lisp loaded. Proceeding with examples")

(defun example (s-expression info-string)
  "Prints info-string and s-expression to standard output and then evaluates
   s-expression and prints the result."
  (format t "~%~%Example: ~A" info-string)
  (format t "~%~%~S" s-expression)
  (format t "~%~S" (eval s-expression))
  )

(example '(encode-program
	   '((A1 INC X1 NIL) (NIL BNZ X1 A1)))
	 "Encoding an L-program.")

(example '(decode-program-number 199)
	 "Decoding a program number.")

(example '(enumerate-programs-from-to 0 10 :print t :return-list nil)
	 "Enumerating L-programs.")

(example '(execute-program '((a1 dec x1 nil) (nil inc y nil)
			    (nil bnz x1 a1))
			  :input-values '(5)
			  :trace t)
	 "Executing an L-program.")

(example '(execute-program-number 199 :trace t)
	 "Executing an encoded L-program")


----CUT HERE---- 

Joe Lammens

BITNET: lammens%cs.Buffalo.EDU@UBVM.BITNET   Internet: lammens@cs.Buffalo.EDU
UUCP: ...!{apple,cornell,decwrl,harvard,rutgers,uunet}!cs.buffalo.edu!lammens