Hi! :)
I'm trying to do a 'Turing machine'... or kind of :)
This is what I got so far:
----------------
(defparameter *reglas* (make-hash-table :test 'equal))
(defun crear-regla (estado-inicial lectura escritura movimiento
estado-final)
(setf (gethash (list estado-inicial lectura) *reglas*)
(list escritura movimiento estado-final)))
(defun borrar-reglas ()
(clrhash *reglas*))
(defun ver-reglas ()
(loop for k being the hash-keys in *reglas* using (hash-value v)
do (format t "(~{~a~^~3t~})~%" (append k v))))
(defun turing (lista &optional (estado 0) (posición 0))
(labels ((trng (lst est pos)
(if (or (= pos (length lst)) (= pos -1) (= est -1))
lst
(let ((acc (gethash (list est (nth pos lst)) *reglas*)))
(setf (nth pos lst) (first acc))
(trng lst (third acc) (+ pos (second acc)))))))
(trng (copy-seq lista) estado posición)))
---------------------------------------
It worked with a little example:
CL-USER> (crear-regla 0 0 1 1 0)
(1 1 0)
CL-USER> (crear-regla 0 1 0 1 0)
(0 1 0)
CL-USER> (turing '(1 0 0 1 0 1 1 0))
(0 1 1 0 1 0 0 1)
CL-USER>
(Note: the 'rules' are given like this: 1) state 2) read 3) write 4)
move [can be +1 (right) or -1 (left) 5) next-state).
Any critics/comments are welcome, but I'm most interested in this part:
(setf (nth pos lst) (first acc))
(trng lst (third acc) (+ pos (second acc)))))))
I mean, first I change an element of a list, and /then/ I use the list
as parameter. I think there *should* be a way to do it directly in the
'trng' call... I mean, I *think* that the first line can be avoided.
Am I right, or should I think in an utility function/macro?
Thank you!!!!
Luis.
LuisGLopez wrote:
>Hi! :)
>I'm trying to do a 'Turing machine'... or kind of :)
>
>This is what I got so far:
[lisp in spanish]
;;;;;;;;;;;;;;;;;;
;translation of code written by LuisGLopez
;;;;;;;;;;;;;;;;;;;
(defparameter *rules* (make-hash-table :test #'equal))
(defun create-rule (state read write move end)
(setf (gethash (list state read) *rules*)
(list write move end)))
(defun clear-rules ()
(clrhash *rules*))
(defun rules ()
(loop for k being the hash-keys in *rules*
using (hash-value v)
do (format t "(~{~â^~3t~})~%" (append k v))))
(defun turing (&optional list (state 0) (position 0))
(labels ((trng (lst s p)
(if (or (= p (length lst))
(= p -1)
(= s -1))
lst
(let ((acc (gethash (list s (nth p lst)) *rules*)))
(setf (nth p lst) (first acc))
(trng lst (third acc) (+ p (second acc)))))))
(trng (copy-seq list) state position)))
;;;;;;;;;;;;;;;;;;;
CL-USER> (create-rule 0 0 1 1 0)
(1 1 0)
CL-USER> (create-rule 0 1 0 1 0)
(0 1 0)
CL-USER> (turing '(1 0 0 1 0 1 1 0))
(0 1 1 0 1 0 0 1)
CL-USER>
first off, using (list estado-inicial lectura) as a hash key and (list
escritura movimiento estado-final) as a data structure are bad ideas.
There are lots of ways you can represent this that make more sense and
are probably more efficient.
as for using (list escritura movimiento estado-final) as a semantic
unit: this style results in completely unreadable code. Unless you use
local assignment (ie a descriptive LET... which you didn't), the only
way for someone to know what a call to (FIRST ACC) means in TURING is
to go find the code where it originated (way back in CREAR-REGLA). This
is a reason why structures and classes were invented.
>Any critics/comments are welcome, but I'm most interested in this part:
>
> (setf (nth pos lst) (first acc))
> (trng lst (third acc) (+ pos (second acc)))))))
>
(coerce list 'vector) turns a list into a vector--making it accessible
with SVREF, a much favorable alternative to NTH
>I mean, first I change an element of a list, and /then/ I use the list
>as parameter. I think there *should* be a way to do it directly in the
>'trng' call... I mean, I *think* that the first line can be avoided.
if you really want you can define something like
(defun set-vector! (n new vector)
(setf (svref n vector) new)
vector)
but only if you think it's that big of a deal
good luck
Nick
LuisGLopez wrote:
> Hi! :)
>
> I'm trying to do a 'Turing machine'... or kind of :)
>
> This is what I got so far:
>
> ----------------
> (defparameter *reglas* (make-hash-table :test 'equal))
>
> (defun crear-regla (estado-inicial lectura escritura movimiento
> estado-final)
> (setf (gethash (list estado-inicial lectura) *reglas*)
> (list escritura movimiento estado-final)))
>
> (defun borrar-reglas ()
> (clrhash *reglas*))
>
> (defun ver-reglas ()
> (loop for k being the hash-keys in *reglas* using (hash-value v)
> do (format t "(~{~a~^~3t~})~%" (append k v))))
>
> (defun turing (lista &optional (estado 0) (posici�n 0))
> (labels ((trng (lst est pos)
> (if (or (= pos (length lst)) (= pos -1) (= est -1))
> lst
> (let ((acc (gethash (list est (nth pos lst)) *reglas*)))
> (setf (nth pos lst) (first acc))
> (trng lst (third acc) (+ pos (second acc)))))))
> (trng (copy-seq lista) estado posici�n)))
> ---------------------------------------
>
> It worked with a little example:
>
> CL-USER> (crear-regla 0 0 1 1 0)
> (1 1 0)
> CL-USER> (crear-regla 0 1 0 1 0)
> (0 1 0)
> CL-USER> (turing '(1 0 0 1 0 1 1 0))
> (0 1 1 0 1 0 0 1)
> CL-USER>
>
> (Note: the 'rules' are given like this: 1) state 2) read 3) write 4)
> move [can be +1 (right) or -1 (left) 5) next-state).
>
> Any critics/comments are welcome, but I'm most interested in this part:
>
> (setf (nth pos lst) (first acc))
> (trng lst (third acc) (+ pos (second acc)))))))
>
> I mean, first I change an element of a list, and /then/ I use the list
> as parameter.
Yes, and observe that an element of a list is not the list.
> I think there *should* be a way to do it directly in the
> 'trng' call... I mean, I *think* that the first line can be avoided.
>
> Am I right, or should I think in an utility function/macro?
You are wrong. the first line is not about the list. It is about tne nth
pos of the list. setf *should* return the value you are storing there,
and that is not what you want to pass to trng (so you cannot code:
(trng (setf (nth.....) ...) ....)
You are doing two different things, writing and moving, there is no
reason they should collapse into one form (other than PROGN <g>).
It will be fine to write an APPLY-TRANSITION function to do the two
different steps (which I gather you already have done).
Don't get me wrong. I commend your striving for a purely functional
one-liner. Just do not force it, is all I am saying.
kt
ps. how did turing get abbrevieated to trng? ewwwww
"LuisGLopez" <············@gmail.com> writes:
> [...]
> I'm trying to do a 'Turing machine'... or kind of :)
> [...]
> CL-USER> (crear-regla 0 0 1 1 0)
> (1 1 0)
> CL-USER> (crear-regla 0 1 0 1 0)
> (0 1 0)
> CL-USER> (turing '(1 0 0 1 0 1 1 0))
> (0 1 1 0 1 0 0 1)
> [...]
What does this mean? I don't see no Turing Machine here!
What about:
(turing :tape (make-infinite-tape :left '(x x)
:right '(- x x)
:blank '-)
:initial-state :init
:final-states '(:done)
:transitions '( ;; This program moves the x's on the left
;; over after the x's on the right.
(:init - -> - :left :when-left)
(:when-left - -> - :right :done)
(:when-left x -> x :left :to-left)
(:to-left x -> x :left :to-left)
(:to-left - -> - :right :decrement)
(:decrement x -> - :right :from-left-to-right)
(:from-left-to-right x -> x :right :from-left-to-right)
(:from-left-to-right - -> - :right :over-right)
(:over-right x -> x :right :over-right)
(:over-right - -> x :left :from-right-to-left)
(:from-right-to-left x -> x :left :from-right-to-left)
(:from-right-to-left - -> - :left :when-left)))
Does this look more like a Turing Machine?
Ok, first, let's build an infinite tape:
(defstruct (tape (:constructor %make-tape) (:conc-name %tape-))
left right blank)
(defun make-infinite-tape (&key (left '()) (right '()) (blank nil))
(%make-tape :left (reverse left) :right (copy-list right) :blank blank))
(defun tape-print (tape &optional (*standard-output* *standard-output*))
(format t "... ~A ~{~A ~}[ ~A ] ~{~A ~}~A ..."
(%tape-blank tape)
(reverse (%tape-left tape))
(if (null (%tape-right tape))
(%tape-blank tape)
(first (%tape-right tape)))
(rest (%tape-right tape))
(%tape-blank tape)))
(defun tape-read (tape)
(if (null (%tape-right tape))
(%tape-blank tape)
(car (%tape-right tape))))
(defun tape-write (tape symbol)
(if (null (%tape-right tape))
(setf (%tape-right tape) (list symbol))
(setf (car (%tape-right tape)) symbol))
symbol)
(defun tape-left (tape)
(push (if (null (%tape-left tape))
(%tape-blank tape)
(pop (%tape-left tape)))
(%tape-right tape))
(values))
(defun tape-right (tape)
(push (if (null (%tape-right tape))
(%tape-blank tape)
(pop (%tape-right tape)))
(%tape-left tape))
(values))
[154]> (loop with tape = (make-infinite-tape :left '(a b c)
:right '(d e f)
:blank '-)
repeat 10 do (tape-right tape) (tape-print tape) (terpri))
... - A B C D [ E ] F - ...
... - A B C D E [ F ] - ...
... - A B C D E F [ - ] - ...
... - A B C D E F - [ - ] - ...
... - A B C D E F - - [ - ] - ...
... - A B C D E F - - - [ - ] - ...
... - A B C D E F - - - - [ - ] - ...
... - A B C D E F - - - - - [ - ] - ...
... - A B C D E F - - - - - - [ - ] - ...
... - A B C D E F - - - - - - - [ - ] - ...
NIL
Now, let's build our Turing Machine. Wikipedia
http://en.wikipedia.org/wiki/Turing_Machine
says that a Turing Machine is made of:
- a finite set of states Q
- a finite set of tape alphabet GAMMA
- an initial set S
- a blank symbol b
- a subset of final states F
- and a transition function DELTA: Q � GAMMA -> Q � GAMMA � {left,right}
b is given to the infinite tape. GAMMA can be deduced from the initial
state of the inifite tape and the TRANSITIONS passed to the TURING
function. Q can be deduced from the TRANSITIONS passed to the TURING function.
S and F are the INITIAL-STATE and FINAL-STATES parameters.
Remains to build the DELTA function from the TRANSITIONS. First,
we'll change the order of the resulting tuples and write:
DELTA: Q � GAMMA -> GAMMA � {left,right} � Q
since we first write the new symbol, then move left or right, and
finally shift the state.
Since we use symbols for Q and GAMMA, we'll use ECASE to compute
DELTA. And we'll return TAPE-LEFT and TAPE-RIGHT for the movement.
So the body of the TURING function will merely be:
(loop
with state = initial-state
with symbol = (tape-read tape)
until (member state final-states)
do (multiple-value-bind (new-symbol move new-state)
(funcall delta state symbol)
(tape-write tape new-symbol)
(funcall move tape)
(setf state new-state
symbol (tape-read tape)))
To make the ECASE statements, we'll use a function. We don't need a
macro, because the function DELTA will be generated at run-time, not
at compilation-time.
(defun make-case (varname transitions &key (key (function first))
(value (function identity))
(gen-body (function identity)))
(loop
with cases = (make-hash-table)
for trans in transitions
do (push (funcall value trans) (gethash (funcall key trans) cases '()))
finally (let ((forms '()))
(maphash (lambda (key value)
(push `((,key) ,(funcall gen-body value)) forms))
cases)
(return `(ecase ,varname ,@forms)))))
We can then write delta as:
`(lambda (state symbol)
,(make-case
'state transitions
:key (function first)
:value (function rest)
:gen-body
(lambda (transitions)
(make-case
'symbol transitions
:key (function car)
:value (function cddr)
:gen-body
(lambda (transitions)
(destructuring-bind ((write move state)) transitions
`(values
(quote ,write)
,(ecase move
((:left) `(function tape-left))
((:right) `(function tape-right)))
(quote ,state))))))))
Finally, we paste the pieces together, and add a few statements to
print the workings of the Turing Machine:
(defun turing (&key (tape (make-infinite-tape))
initial-state final-states transitions
(tracep nil))
(assert (and initial-state final-states transitions))
(let ((delta (compile
nil
`(lambda (state symbol)
,@(when tracep `((format t "~20A ~A --> " state symbol)))
,(make-case
'state transitions
:key (function first)
:value (function rest)
:gen-body
(lambda (transitions)
(make-case
'symbol transitions
:key (function car)
:value (function cddr)
:gen-body
(lambda (transitions)
(destructuring-bind ((write move state)) transitions
`(values
(quote ,write)
,(ecase move
((:left) `(function tape-left))
((:right) `(function tape-right)))
(quote ,state)))))))))))
(loop
with state = initial-state
with symbol = (tape-read tape)
initially (when tracep
(format t "~20A " state) (tape-print tape) (terpri))
until (member state final-states)
do (multiple-value-bind (new-symbol move new-state)
(funcall delta state symbol)
(tape-write tape new-symbol)
(funcall move tape)
(setf state new-state
symbol (tape-read tape))
(when tracep
(format t "~20A " state) (tape-print tape) (terpri)))
finally (return tape))))
[153]> (turing :tape (make-infinite-tape :left '(x x)
:right '(- x x)
:blank '-)
:tracep t
:initial-state :init
:final-states '(:done)
:transitions '( ;; This program moves the x's on the left
;; over after the x's on the right.
(:init - -> - :left :when-left)
(:when-left - -> - :right :done)
(:when-left x -> x :left :to-left)
(:to-left x -> x :left :to-left)
(:to-left - -> - :right :decrement)
(:decrement x -> - :right :from-left-to-right)
(:from-left-to-right x -> x :right :from-left-to-right)
(:from-left-to-right - -> - :right :over-right)
(:over-right x -> x :right :over-right)
(:over-right - -> x :left :from-right-to-left)
(:from-right-to-left x -> x :left :from-right-to-left)
(:from-right-to-left - -> - :left :when-left)))
INIT ... - X X [ - ] X X - ...
INIT - --> WHEN-LEFT ... - X [ X ] - X X - ...
WHEN-LEFT X --> TO-LEFT ... - [ X ] X - X X - ...
TO-LEFT X --> TO-LEFT ... - [ - ] X X - X X - ...
TO-LEFT - --> DECREMENT ... - - [ X ] X - X X - ...
DECREMENT X --> FROM-LEFT-TO-RIGHT ... - - - [ X ] - X X - ...
FROM-LEFT-TO-RIGHT X --> FROM-LEFT-TO-RIGHT ... - - - X [ - ] X X - ...
FROM-LEFT-TO-RIGHT - --> OVER-RIGHT ... - - - X - [ X ] X - ...
OVER-RIGHT X --> OVER-RIGHT ... - - - X - X [ X ] - ...
OVER-RIGHT X --> OVER-RIGHT ... - - - X - X X [ - ] - ...
OVER-RIGHT - --> FROM-RIGHT-TO-LEFT ... - - - X - X [ X ] X - ...
FROM-RIGHT-TO-LEFT X --> FROM-RIGHT-TO-LEFT ... - - - X - [ X ] X X - ...
FROM-RIGHT-TO-LEFT X --> FROM-RIGHT-TO-LEFT ... - - - X [ - ] X X X - ...
FROM-RIGHT-TO-LEFT - --> WHEN-LEFT ... - - - [ X ] - X X X - ...
WHEN-LEFT X --> TO-LEFT ... - - [ - ] X - X X X - ...
TO-LEFT - --> DECREMENT ... - - - [ X ] - X X X - ...
DECREMENT X --> FROM-LEFT-TO-RIGHT ... - - - - [ - ] X X X - ...
FROM-LEFT-TO-RIGHT - --> OVER-RIGHT ... - - - - - [ X ] X X - ...
OVER-RIGHT X --> OVER-RIGHT ... - - - - - X [ X ] X - ...
OVER-RIGHT X --> OVER-RIGHT ... - - - - - X X [ X ] - ...
OVER-RIGHT X --> OVER-RIGHT ... - - - - - X X X [ - ] - ...
OVER-RIGHT - --> FROM-RIGHT-TO-LEFT ... - - - - - X X [ X ] X - ...
FROM-RIGHT-TO-LEFT X --> FROM-RIGHT-TO-LEFT ... - - - - - X [ X ] X X - ...
FROM-RIGHT-TO-LEFT X --> FROM-RIGHT-TO-LEFT ... - - - - - [ X ] X X X - ...
FROM-RIGHT-TO-LEFT X --> FROM-RIGHT-TO-LEFT ... - - - - [ - ] X X X X - ...
FROM-RIGHT-TO-LEFT - --> WHEN-LEFT ... - - - [ - ] - X X X X - ...
WHEN-LEFT - --> DONE ... - - - - [ - ] X X X X - ...
#S(TAPE :LEFT (- - -) :RIGHT (- X X X X) :BLANK -)
[154]>
If there was performance problems with using symbols and ECASE, it
would be easy enough to collect the states and the symbols, to number
them and to use fixnums and arrays instead of ECASE.
--
__Pascal Bourguignon__ http://www.informatimago.com/
"Logiciels libres : nourris au code source sans farine animale."
"LuisGLopez" <············@gmail.com> writes:
> Hi! :)
>
> I'm trying to do a 'Turing machine'... or kind of :)
For inspiration, you can look at a version I programmed recently for a
course on Computer Science:
http://www-dbs.informatik.uni-heidelberg.de/teaching/ws2006/info1/tm.lisp
It also contains a factorial function for the Turing machine.
Yours, Nicolas.
Nicolas Neuss wrote:
> "LuisGLopez" <············@gmail.com> writes:
>
> > Hi! :)
> >
> > I'm trying to do a 'Turing machine'... or kind of :)
>
> For inspiration, you can look at a version I programmed recently for a
> course on Computer Science:
>
Hi!!! :)
Thank you ALL *so* much for all your replies; as always, I learned a
lot from them.
Luis.