; -------------------------------------------------------------------------------------------------------------------------
; mAbducer 1.2 solves rearrrangement problems and automatically programs two alternative functions
; (for-loop and while-loop) for their universal solution, and translates the while-loop into everyday language.
; It programs problems with crossed-dependencies such as the riffle shuffle, which call for two stacks in their solution,
; and so it copes with static and dynamic loops. To use the program type (intro) followed by return.
; -------------------------------------------------------------------------------------------------------------------------
(defvar *system-name* "Abducer")
(defvar *version* 1.2)
; -------------------------------------------------------------------------------------------------------------------------
; Copyright (C) 2014 Mental Models and Reasoning Lab
;
; Website: http://mentalmodels.princeton.edu
; Contact: Phil Johnson-Laird, who wrote the code (phil@princeton.edu), with
; help and advice from:
; Sangeet Khemlani (skhemlani@gmail.com)
; Max Lotstein (mlotstein@gmail.com)
;
; This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License
; as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version.
;
; This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied
; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
;
; For a copy of the GNU General Public License, please visit:
; http://www.gnu.org/licenses/gpl-2.0.html or write to the Free Software Foundation Inc., 51 Franklin Street, Fifth Floor,
; Boston, MA 02110-1301, USA.
; -------------------------------------------------------------------------------------------------------------------------
#| INDEX
Part 1: How the program works and functions that introduce the program and allow the user to run it
Part 2: Predefined problems
Part 3: The high-level functions
Part 4: Minimal-solve, which finds a minimal solution to an instance of a problem
Part 5: The principal solve function, which unlike minimal-solve, is computationally tractable
Part 6: The three basic moves on the railway track
Part 7: Find the loop in a trace of moves returned by solve
Part 8: Recovery of programming structure from two traces of moves returned by solve
Part 9: Automated programming
Part 10: Translates the program's while-functions into everyday language
Part 11: Matrix algebra for solving three simultaneous equations
Part 12: Useful functions (delete from public code) |#
; -------------------------------------------------------------------------------------------------------------------------
; Part 1: Functions that introduce the program and allow the user to run it
; -------------------------------------------------------------------------------------------------------------------------
#|
HOW THE PROGRAM WORKS
The 'railway' environment is represented in a simple list structure:
left siding right
track | track
| | |
'( (a b c) (d e) (f g) )
where cars can move from left to siding, from siding to left, and from left to right. They
cannot move directly from siding to right. Any number of cars can be shifted in a single move,
e.g., d and e in the situation above could both move to left track.
First, the program solves two particular problem instances of a problem, given the start
state and the goal state, e.g., a palindrome problem such as:
Start state Goal state
((a b c c b a) nil nil) => (nil nil (a a b b c c))
It uses a simple tractable procedure, solve, for solving problems, but it also has a function,
minimal-solve that explores all possible sequences of moves to find the set of minimal
solutions, i.e., those that depend on the smallest possible number of moves. Both functions
return the sequence of moves that solve the problem, such as:
(S 2 R 3 L 1 R 2 L 1 R 1)
where:
S 2 denotes move two cars to SIDING
R 3 denotes move three cars (from left track) to RIGHT track.
L 1 denotes move one car (from siding) to LEFT track.
Minimal-solve constructs all feasible derivations breadth first, finding feasible
continuations, and adding them to a current sequence of moves in order to create a set of new
sequences. When a sequence can go no further or solves the problem, it is removed from
the list, and so the function ends with a set of successful derivations -- sometimes
more than one with the shortest number of moves -- and failures. It returns the set of minimal
solutions, i.e., a trace of the required sequence of moves. The solve function carries out a
loop of operations until it solves the problem:-
If more cars on left track can be moved to right to satisfy part of the goal than cars on the siding
can be so moved (to left track), it makes the immediate rightward move;
elseif a car on left track satisfies part of the goal but is blocked from moving, moves blocking
cars onto siding to free up optimal number of cars;
otherwise, with no such cars on left track, moves one or more cars from siding to left track to satisfy
largest possible part of goal.
The program solves problems that do not require loops, but does not produce functions for their solution,
because they are just a list of moves, e.g.:
(abduce 'hd-to-tl hd-to-tl-problem '(a b c d))
Second, find-struct takes list of two lists of moves from first stage, and recovers their loop structure,
where a loop contains at least 2 repeated operations. Loops are static as shown in the loops for solving
palindromes of various lengths:
(L 1 R 2)
(L 1 R 2 L 1 R 2)
The static loop here is: L 1 R 2, which is iterated 0, 1, 2 ... times depending on the length of the train
in the starting structure. Find-struct rtns a sequence of three-part structures from the pair of move
sequences:
Pre-loop Loop Post-loop
where any of these constituents could be empty. Example:-
Pre-loop Loop Post-loop
(R 1 S 1 R 1 L 1 R 2)
(R 1 S 1 R 1 S 1 R 1 L 2 R 3)
(R 1 S 1 R 1 S 1 R 1 S 1 R 1 L 3 R 4)
The number of iterations of a loop depends on the length of the start state, and solve-eq takes two input
move sequences to solve a pair of simultaneous equations, to recover the values of a and b in two equations
of the form:
no. of iterations = a.length-of-input + b
Solve-eq is also used to solve the number of cars in pre-loop and post-loop moves if they vary according to
length of input (as in the post-loop above).
Other loops are dynamic in that the number of cars for at least one move in the loop depends on both
the initial length of the train and the number of iterations of the loop that have occurred. For example, the
"riffle in" shuffle interpolations cars in even-numbered positions between those in odd-numbered positions:
a b c d e f becomes a d b e c f
It depends on a loop of four moves. It its first iteration for a train of this length, they are:
(R 1 S 2 R 1 L 2)
but in its second iteration to solve the problem, they are:
(R 1 S 1 R 1 L 1)
So, the first and third moves are "static" in that the number of cars moved remain the same regardless of the
length of the train or iteration, whereas the second and final move are "dynamic" in that their values decline
with the number of iterations. In order to construct a for-loop, the program solves three simultaneous equations
in order to recover the values of a, b, and c required to compute:
number-of-cars-in-a-move = a(number-of-iterations) + b(ith-iteration) + c
Dynamic problems -- those with at least one dynamic move in a loop -- require at least one car to be moved
onto the siding more than once. For example, here's the solution to the riff-in problem above, and
car D has to move onto the siding twice, once as a result of S 2, and later as a result of S 1:
R 1: ((A B C D E) NIL (F))
S 2: ((A B C) (D E) (F))
R 1: ((A B) (D E) (C F))
L 2: ((A B D E) NIL (C F))
R 1: ((A B D) NIL (E C F))
S 1: ((A B) (D) (E C F))
R 1: ((A) (D) (B E C F))
L 1: ((A D) NIL (B E C F))
R 2: (NIL NIL (A D B E C F))
To construct while-loops, whether static or dynamic, the program merely simulates solutions to two problems,
and observes the conditions on entering a loop and on exiting it in order to infer the conditions governing
the continuation of the loop. When they fail, the program exits the loop.
Third, the program uses the list structure to formulate a for-loop and the simulation to formulate a while-
loop. In effect, it translates them into a Lisp function. The resulting function is then given a new start-state
to solve. The program translates the function embodying a while-loop into everyday language.
|#
(defun intro()
"Description of what the program does and how to use it"
(let (response)
(terpri)(princ "mAbducer solves universal rearrrangement problems containing a single
loop, and it automatically programs two functions for solving any instance of a
class of problems,such as reversing the order of a list, sorting palindromes, and
parity-sorts (the inverse of riffle shuffles). One function uses a FOR-loop, which
calls for the solution of two simultaneous linear equations in order to determine
the number of iterations. The other function uses a WHILE-loop, which though more
powerful computationally, is more plausible psychologically, because it calls for
examining what is common to simulations of two instance of a problem at the start and
end point of the loops in their solution. The program also translates the while-loop
into everyday English. The program solves problems with 'dynamic' loops, that is,
in which the number of operands for a move in a loop depends on how many times
the loop has been iterated, e.g., move left 5 cars on the first iteration, move left
3 cars on the second iteration, and so on. Users can repeat a re-arrangment until it
outputs the initial state or exceeeds the maximum number of iterations.
Rearrangment problems can be set in the 'railway' environment, consisting of
a track running from left to right, with a siding which cars can move to or from
the left track only. This environment is equivalent to a finite-state automaton
equipped with two stacks, i.e., it has universal Turing machine power, because both
the siding and the left track can be used as stacks. But, the functions for solving
re-arrangement problems never need more than for-loops, i.e., minimal recursion.")
(terpri)(princ "There are four main ways to use the program. 1. Run a test on a set
of existing problems. 2. Enter a new problem. 3. Determine the minimal solution to a problem.
4. See an illustration of the effects of the repeated use of a re-arrangement until the result
gets back to the starting point.
Please type 1, 2, 3, or 4 to make your choice.")
(terpri)
(setf response (read-line-no-punct))
(cond((equal (first response) 1)(grand-test all-problems))
((equal (first response) 2)(read-in-problem))
((equal (first response) 3)(read-in-minimal-solution))
((equal (first response) 4)
(recursive-rearrange 10 '(palind palindrome-problem (a1 b1 c1 d1 e1 f1 g1 g2 f2 e2 d2 c2 b2 a2))))
(t (terpri)(princ "I assume you want to type in your own problem.")(terpri)
(read-in-problem)))))
(defun grand-test(all-problems)
"funcalls the program to a list of problems"
(let ((count 1) feedback)
(dolist (prob all-problems feedback)
(princ "PROBLEM ")(princ count)(terpri)
(setf count (+ count 1))
(cond((null (eval prob))(terpri)(princ "mAbducer fails with problem. ")
(setf feedback (append feedback (list (eval (cadr prob))))))))
(princ "mAbducer fails with the following problems, where 'NIL' means none:")
(dolist (itm feedback)(print itm))))
(defun read-in-problem()
"gets a new sort of problem from user and applies abduce to it"
(prog(temp-start temp-goal first-problem second-problem name addn new-problem)
(princ "You're going to type in two instances of the same problem with different numbers of cars.")(terpri)
(princ "So, for the first instance, ")
loop
(princ "What is the arrangment of cars on the left track? ")(terpri)
(princ "Please type it with spaces between the letters denoting cars, e.g.: A B C D E, followed by return. ")(terpri)
(setf temp-start (read-line-no-punct))
(princ "Now type in the re-arrangement of the previous cars that you require on the right track?")(terpri)
(setf temp-goal (read-line-no-punct))
(cond((well-formedness (list temp-start temp-goal))
(if (null first-problem)
(setf first-problem (list temp-start temp-goal))
(setf second-problem (list temp-start temp-goal))))
(t (terpri)(princ "Please try again.")(terpri)(go loop)))
(cond((null second-problem)
(terpri)(princ "Now, for the second instance of the same problem, please use a longer train.")(terpri)
(go loop))
(t (terpri)(princ "Finally, please write a short name for your problem, such as: rev1")(terpri)
(setf name (first (read-line-no-punct)))
(terpri)
(princ "The program will solve the problem and abduce two sorts of function for solving it.")
(terpri)
(setf addn (+ (length (first second-problem))
(- (length (first second-problem))(length (first first-problem)))))
(setf new-problem (rtn-n addn '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
(abduce name (list first-problem second-problem) new-problem)
(return t)))))
(defun read-in-minimal-solution()
"reads in a problem and rtns its minimal solution"
(let (temp-start temp-goal)
(princ "You're going to type in a problem, and the program will find its minimal solution or solutions.")(terpri)
(princ "But, the task is not computationally tractable, and so please don't use problems with a large number of cars")
(terpri)(princ "or else the program will take forever.")(terpri)
(princ "What is the arrangment of cars on the left track? ")(terpri)
(princ "Please type it with spaces between the letters denoting cars, e.g.: A B C D E, followed by return. ")(terpri)
(setf temp-start (read-line-no-punct))
(princ "Now type in the re-arrangement of the previous cars that you require on the right track, followed by
return.")(terpri)
(setf temp-goal (read-line-no-punct))
(cond((well-formedness (list temp-start temp-goal))
(minimal-solve (list (list temp-start nil nil)(list nil nil temp-goal))) )) ))
(defun well-formedness(problem)
"checks that each car in the start occurs once in the goal"
(let ((start (first problem))(goal (second problem)))
(prog()
loop
(cond((null start)
(cond((null goal)(return t))
(t (princ "Error a car in the goal isn't in the start.") (return nil))))
((member (first start) goal)
(setf goal (remove (first start) goal :count 1))
(setf start (rest start))(go loop))
(t (princ "Error a car in the start, ")(princ (first start))(princ ", isn't in the goal.")(terpri)
(return nil))))))
(defun read-line-no-punct(&optional in-char)
(let ((input (read-line)))
(cond( in-char (setf input (concatenate 'string (string in-char) input))))
(read-from-string
(concatenate 'string "(" (substitute-if #\space #'punctuation-p
input) ")" ))))
(defun punctuation-p(char)
(find char ",;:'!?#()\\\""))
; -------------------------------------------------------------------------------------------------------------------------
; Part 2: Predefined problems
; -------------------------------------------------------------------------------------------------------------------------
#|a list of predefined problems
Name 1st instance 2nd instance New
for problem start-state and end-state start-state and end-state start-state
| | | | | |
(abduce 'sw-pairs '(((a b c d e f)(b a d c f e))((a b c d)(b a d c))) '(a b c d e f g h)) |#
(defvar all-problems '(
; One stack problems with nested dependencies:- No of recursions to rtn to original state
(abduce 'reve reverse-problem '(a b c d e f g h i)) ; 2
(abduce 'palind palindrome-problem '(a1 b1 c1 d1 e1 f1 g1 g2 f2 e2 d2 c2 b2 a2)) ; 9
(abduce 'inv-palind inv-pal-problem '(a1 b1 c1 d1 e1 f1 f2 e2 d2 c2 b2 a2)) ; 6
(abduce 'center-palind centre-palindrome-problem '(a1 b1 c1 d1 e1 f1 e1 d2 c2 b2 a2)) ; 4
(abduce 'par parity-problem '(a b c d e f g h i j)) ; 3
(abduce 'id identity-problem '(a b c d e)) ; not a recursive problem
(abduce 'hd-to-tl hd-to-tl-problem '(a b c d)) ; not a recursive problem
(abduce 'amb-pal ambig-pal-problem '(a b c d e f f e d c b a)) ; 9
(abduce 'c-palind c-palindrome-problem '(a1 a2 b1 b2 c1 c2 d1 d2 e1 e2 f1 f2)) ; 4
(abduce 'back-riff-out back-riffle-out '(a b c d e f g h i j))
(abduce 'back-riff-in back-riffle-in '(a b c d e f g h i j)) ; 4
(abduce 'embed embed '(aa ab ac ad ae ba bb bc bd be ca cb cc cd ce da db dc dd de ea eb ec ed ee)) ; 2
; Two stack problem with crossed dependencies, i.e., at least one car has to move onto siding twice:-
(abduce 'riff-in riffle-in '(a b c d e f g h i j)) ; aka the faro shuffle (see Diaconis paper) ; 3
(abduce 'riff-out riffle-out '(a b c d e f g h i j)) ; 6
(abduce 'dynam dyn '(a b c d e f g h i j)) ; 4
(abduce 'dynam-inv dyn-inv '(a b c d e f g h i j)) ; 4
(abduce 'utm utm-problem '(a a b b c c)))) ; 13
; Definitions of problems with two instances of start-goal pairs
(defvar identity-problem '(((a b c d)(a b c d))((a b c)(a b c))))
(defvar reverse-problem '(((a b c d e)(e d c b a))((a b c d)(d c b a))))
(defvar palindrome-problem '(((a1 b1 c1 d1 e1 e2 d2 c2 b2 a2)(a1 a2 b1 b2 c1 c2 d1 d2 e1 e2))((a1 b1 c1 d1 d2 c2 b2 a2)(a1 a2 b1 b2 c1 c2 d1 d2))))
(defvar ambig-pal-problem '(((a b c d e e d c b a)(a a b b c c d d e e))((a b c d d c b a)(a a b b c c d d))))
(defvar inv-pal-problem '(((a1 b1 c1 d1 e1 e2 d2 c2 b2 a2)(a2 a1 b2 b1 c2 c1 d2 d1 e2 e1))((a1 b1 c1 d1 d2 c2 b2 a2)(a2 a1 b2 b1 c2 c1 d2 d1))))
(defvar c-palindrome-problem '(((a1 a2 b1 b2 c1 c2 d1 d2)(a1 b1 c1 d1 d2 c2 b2 a2))((a1 a2 b1 b2 c1 c2)(a1 b1 c1 c2 b2 a2))))
(defvar parity-problem '( ((a b c d e f g h)(a c e g b d f h))((a b c d e f)(a c e b d f))))
(defvar centre-palindrome-problem '( ((a1 b1 c1 d1 e1 d2 c2 b2 a2)(a1 a2 b1 b2 c1 c2 d1 d2 e1))((a1 b1 c1 d1 c2 b2 a2)
(a1 a2 b1 b2 c1 c2 d1))))
(defvar riffle-in '( ((a b c d e f g h)(a e b f c g d h)) ((a b c d e f)(a d b e c f))))
(defvar riffle-out '( ((a b c d e f g h)(e a f b g c h d)) ((a b c d e f)(d a e b f c))))
(defvar back-riffle-out '( ((a b c d e f g h)(h a g b f c e d)) ((a b c d e f)(f a e b d c))))
(defvar back-riffle-in '( ((a b c d e f g h)(a h b g c f d e)) ((a b c d e f)(a f b e c d))))
(defvar dyn '(((A B C D E F G H) (D E C F B G A H)) ((A B C D E F) (C D B E A F))))
(defvar dyn-inv '(((A B C D E F G H)(E D F C G B H A))((A B C D E F)(D C E B F A))))
(defvar hd-to-tl-problem '( ((a b c d e f)(f b c d e a))((a b c d e)(e b c d a))))
(defvar utm-problem '( ((a a a a a b b b b b c c c c c)(a b c a b c a b c a b c a b c))
((a a a a b b b b c c c c)(a b c a b c a b c a b c))))
(defvar embed '( ((aa ab ac ad ba bb bc bd ca cb cc cd da db dc dd)(dd dc db da cd cc cb ca bd bc bb ba ad ac ab aa))
((aa ab ac ba bb bc ca cb cc)(cc cb ca bc bb ba ac ab aa))))
(defvar two-loops '( ((a b c d e f g h)(d c b a h g f e))((a b c d e f)(c b a f e d))))
; -------------------------------------------------------------------------------------------------------------------------
; Part 3: The high-level functions
; -------------------------------------------------------------------------------------------------------------------------
(defun recursive-rearrange(max-n lis)
"applies same rearrangement recursively until either output is same as original input or until n of recursions = max-n
e.g. (recursive-rearrange 5 '(riff-in riffle-in nil))"
(let* ((name (first lis))(problems (eval (second lis)))(new-problem (third lis))
(original-start (caar problems)) (count 1) current output)
(prog()
(setf new-problem (list (caar problems) nil nil))
(princ "The initial state was ")(princ (first new-problem))(terpri)
loop
(setf current (third (funcall name new-problem)))
(setf output (append output (list current)))
(cond((or (= count max-n)(equal original-start current))
(princ "After ")(princ count)(princ " recursions of ")(princ name)(princ ", we get back to the start:")
(return output))
(t (setf new-problem (list current nil nil))
(setf count (+ count 1))
(go loop))))))
; A global variable if set to T, prints many more diagnostics
(defvar *print-diagnostics* nil)
(defun abduce(name two-start-goals new-start)
"calls abdu twice, once for for-loop and once for while-loop; translate puts latter
into informal language"
(let (for-fn while-fn)
(if (< (length (first(first two-start-goals)))(length (first(second two-start-goals))))
(setf two-start-goals (reverse two-start-goals)))
(princ "Abducing a FOR-loop to solve the universal problem of ")(princ name)(terpri)
(setf for-fn (abdu name 'for two-start-goals new-start))
(cond((test-functionp for-fn)
(terpri)(terpri)(princ "Abducing a WHILE-loop to solve the universal problem of ")
(princ name)(terpri)
(setf while-fn (abdu name 'while two-start-goals new-start))(terpri)
(cond((test-functionp while-fn)
(translate while-fn)
while-fn)
(t (princ " Exit")(terpri) nil)))
(for-fn t) ; in case that abdu rtns t e.g. for identity fn
(t (princ " Exit ")(terpri) nil))))
(defun abdu(name loop-type two-start-goals new-start)
"solves the two problems, prints traces of moves, rejects problems with traces of same length, & calls ab"
(let* ((problem-long (list (list (first (first two-start-goals)) nil nil)
(list nil nil (second (first two-start-goals)))))
(problem-short (list (list (first (second two-start-goals)) nil nil)
(list nil nil (second (second two-start-goals)))))
(trace-l (solve problem-long))
(trace-s (solve problem-short)))
(princ "The two sequences of moves are:- ")(print trace-s)(print trace-l)
(cond((= (length trace-s)(length trace-l))
(terpri) (princ "The two sequences are the same length, i.e., not a recursive problem.")
(terpri) t)
(t (ab name loop-type new-start trace-l trace-s problem-short problem-long)))))
(defun ab(name loop-type new-start trace-l trace-s problem-short problem-long)
"finds the loops in the two traces, then the structure of solutions, calls auto-program, and checks correct
solution on new-start and problem-short and problem-long"
(let* ((two-traces (list trace-l trace-s))
(long-loop (select-one-loop (find-loops trace-l)))(short-loop (first (find-loops trace-s)))
(structure (find-struct (list short-loop long-loop)))
fun-def fun final-track
(new-problem (list new-start nil nil)))
(cond((null structure)(terpri)(princ "Program cannot find a single unique loop structure.")(terpri) nil)
(t
(if (equal loop-type 'for)
(setf fun-def (auto-program name loop-type structure problem-short problem-long two-traces))
(setf fun-def (auto-program name loop-type structure problem-short problem-long two-traces)))
(terpri)(princ "The new function is:-")
(pprint fun-def)(terpri)
(princ "Applying the abduced function to a new problem ")(princ new-problem)(princ ":-")
(setf fun (eval fun-def))
(setf final-track (funcall fun new-problem))
(cond((and (null (first final-track))(null (second final-track))(third final-track)
(correct-solution name problem-short)(correct-solution name problem-long))
fun-def)
(t (terpri)(princ "Code for ")(princ name)(princ " does NOT work.") nil))))))
(defun test-functionp(itm)
(if(listp itm)
(if (> (length itm) 0) t)))
(defun correct-solution(name problem)
"runs the created fn, name, on an existing problem and compares result with original goal"
(let ( ; (original-start (caar problem))
(original-goal (third (cadr problem))) final-track)
(setf *print-diagnostics* nil)
(setf final-track (funcall name (first problem)))
(if (equal original-goal (third final-track)) t)))
; -------------------------------------------------------------------------------------------------------------------------
; Part 4: Finding a minimal solution to a particular instance of a problem
;--------------------------------------------------------------------------------------------------------------------------
#|
minimal-solve works for the four sort of problem in Khemlani, S.S., Mackiewicz, R., Bucciarelli, M, & Johnson-Laird (2013).
Kinematic mental simulations in abduction and deduction. Proceedings of the National Academy of Sciences, 110 (42),
16766-16771. http://www.pnas.org/cgi/doi/10.1073/pnas.1316275110
minim no of moves mean no ops No. of lines in output
reversals of 6 cars stated min no of moves 12 12(16 ops) 1.33 5
palindrome (A B C D E F)(A F B E C D) 6 6(10 ops) 1.67 8
parity-sort (A B C D E F)(A C E B D F) 7 7(10 ops) 1.43 5
faro shuffle (A B C D E F) (A D B E C F) 9 9(12 ops) 1.33 5
One difference between solve and minimal-solve is solve yields only a single solution, which may
be minimal:
(solve '(((a a a b b b c c c) nil nil)(nil nil (a b c a b c a b c)))) yields:
The problem is solved in 9 moves and a total number of moved cars of 19
(R 1 S 4 R 2 L 3 R 2 S 1 R 1 L 2 R 3)
In contrast, minimal-solve records all possible solutions, including all the minimal ones:
(minimal-solve '(((a a a b b b c c c) nil nil)(nil nil (a b c a b c a b c)))) yields:
Number of solutions is 216
Number of MINIMAL solutions is 4
Number of moves in a minimal solution is 9
The set of minimal solutions is
((R 1 S 4 R 2 L 3 R 1 S 1 R 2 L 2 R 3) (R 1 S 4 R 2 L 3 R 2 S 1 R 1 L 2 R 3) (R 1 S 4 R 2 L 4 R 1 S 2 R 2 L 2 R 3)
(R 1 S 4 R 2 L 3 R 2 S 2 R 1 L 3 R 3)) |#
(defun minimal-solve (problem)
"Generates solutions in parallel, halts when all sequences either yield a solution or fail. Delivers the set of
minimal solutions to problem, i.e., those taking a minimal number of moves"
(let (aline (lines (list (list (append (cons 'nil (list (first problem)))(cddr (second problem))))))
continuations )
(terpri)(princ "Some problems take several minutes to solve, so please be patient.")(terpri)
(prog(soln successes failures (no-of-successes 0))
loop
(setf aline (first lines) lines (rest lines))
(cond((setf continuations (make-moves (first (last aline))))
(setf lines (append lines (subduo aline continuations)))
(cond((setf soln (test-success lines))
(setf no-of-successes (+ 1 no-of-successes))
(setf lines (remove-soln soln lines))
(terpri)(princ "successes ")(princ successes)(terpri)
(setf successes (update-successes (return-moves-only (sum-operands soln)) successes))))
(cond(*print-diagnostics* (terpri)(princ "Lines ")(prin-all-lines lines)))
(go loop))
(lines (append failures (list (sum-operands aline)))(go loop))
(t (terpri)(princ "Number of solutions is ")(princ no-of-successes)(terpri)
(princ "Number of MINIMAL solutions is ")(princ (length successes))(terpri)
(princ "Number of moves in a minimal solution is ")(princ (/ (length (first successes)) 2))(terpri)
(princ "The set of minimal solutions is ")(terpri)
(return successes))))))
(defun update-successes (solution successes)
"if solution shorter than first.successes rtns solution, elseif equal in length adds to successes; else rtns successes"
(cond((= (length solution)(length (first successes)))
(append successes (list solution)))
((or (null successes)
(< (length solution)(length (first successes))))
(list solution))
(t successes)))
(defun make-moves (move+track+goal)
"rtns effect of each new move given current move+track+goal, updating goal as necessary"
(let((goal (third move+track+goal))(list-of-new-moves (find-feasible-moves move+track+goal)))
(prog(move new-track updated-tracks)
loop
(cond((null (setf move (first list-of-new-moves)))(return updated-tracks))
((setf new-track (funcall move 1 (second move+track+goal)))
(if (equal 'R move)
(setf goal (reverse(rest(reverse goal)))))
(setf updated-tracks (append updated-tracks (list (list move new-track goal))))
(setf list-of-new-moves (rest list-of-new-moves))(go loop))
(t (return updated-tracks))))))
(defun find-feasible-moves(last-move+track+goal)
"from last move, current track, and goal, rtns all feasible moves: R iff satifies last.car in goal,
and L or S provided each is not preceded by the other - to prevent shuttling between the two ad infinitum, e.g.
(find-feasible-moves '(R ((a a b b c)(c) (c))(a b a b c))) => (S L R)"
(let* ((last-move (first last-move+track+goal))(current-track (second last-move+track+goal))
(goal (third last-move+track+goal))(left-track (first current-track))(siding (second current-track))
feasible-moves)
(if (and left-track (equal (last left-track)(last goal)))
(setf feasible-moves (cons 'R feasible-moves)))
(if (and siding (not (equal 'S last-move)))
(setf feasible-moves (cons 'L feasible-moves)))
(if (and left-track (not (equal 'L last-move)))
(setf feasible-moves (cons 'S feasible-moves)))
feasible-moves))
(defun subduo(itm lis)
"sticks itm onto end of each x in lis -- from library of J-L fns"
(mapcar #'(lambda(x)(reverse (cons x (reverse itm)))) lis))
(defun test-success(lines)
"rtns t iff only a sequence of moves in lines solves the problem, i.e., it has a null.goal"
(let (output)
(dolist (aline lines)
(dolist (state aline)
(if (null (first (last state)))(setf output aline)))
(if output (return output)))))
(defun remove-soln(soln lines)
"rtns lines without soln -- NB the recursive version ran out of memory"
(let (output)
(dolist (line lines)
(cond((equal soln line) t)
(t (setf output (append output (list line))))))
output))
(defun sum-operands(line)
"adds up the frequency of adjacent same moves of one car, and inserts them into a sequence, e.g.
(sum-operands '((S ((A B) (C) NIL) (C B A)) (S ((A) (B C) NIL) (C B A)) (R (NIL (B C) (A))))) =>
(((S 2) ((A) (B C) NIL) (C B A)) ((R 1) (NIL (B C) (A))))"
(prog(state state+1 move move+1 output (count 1))
loop
(setf state (first line) state+1 (second line))
(setf move (first state) move+1 (first state+1))
(cond((and (null move) move+1) t)
((and move (null move+1))(return (append output (list (cons (list move count)(rest state))))))
((equal move move+1)(setf count (+ 1 count)))
((and move move+1)(setf output (append output (list (cons (list move count)(rest state)))))
(setf count 1)))
(setf line (rest line))
(go loop)))
(defun prin-all-lines(lines)
"calls prin-line to print each move+track+goal in each line in lines"
(dolist (line lines)
(dolist (state line)
(print state))
(terpri))
(terpri))
(defun return-moves-only(line)
"prints only the moves in each state in a line"
(let(output)
(dolist (state line output)
(setf output (append output (list (first state)))))
(flatten-lis output)))
; -------------------------------------------------------------------------------------------------------------------------
; Part 5: The solve function, which is tractable
; -------------------------------------------------------------------------------------------------------------------------
(defun solve(problem)
"solves a re-arrangement problem using a minimal number of moves for the predefined problems"
(let ((track (first problem))(reverse-goal (reverse (third (second problem)))))
(princ "The start is ")(princ track)(princ " and the goal is ")(princ (third (second problem)))
(setf *print-diagnostics* t)
(prog((no-of-moves 0)(no-of-moved-cars 0)(no-of-cars 0) move name trace)
loop
(let* ((left (first track))(siding (second track))
(n-on-L (length (match-starts (reverse left) reverse-goal)))
(n-on-S (length (match-starts siding reverse-goal))))
(cond((null reverse-goal)(terpri)(princ "The problem is solved in ")(princ no-of-moves)
(princ " moves and a total number of moved cars of ")
(princ no-of-moved-cars)(terpri)(return (reverse trace)))
((and (> n-on-L 0)(> n-on-L n-on-S)) ; Move R
(setf no-of-cars n-on-L move #'R name 'R))
((and (member (first reverse-goal) left)(= n-on-L 0)) ; Move S ?test (= n-on-S 0)
(setf no-of-cars (find-n-for-s (reverse left) reverse-goal) move #'S name 'S))
((not (member (first reverse-goal) left)) ; Move L
(setf no-of-cars (find-n-for-L track reverse-goal) move #'L name 'L))
(t (print '(Error -- problem is impossible to solve))(return nil)))
(setf track (funcall move no-of-cars track)
no-of-moves (+ 1 no-of-moves) no-of-moved-cars (+ no-of-moved-cars no-of-cars)
trace (cons no-of-cars (cons name trace)))
(if (equal name 'R)(setf reverse-goal (remove-from-lis no-of-cars reverse-goal))) ; substituted for n-on-L
(go loop)))))
(defun find-n-for-S(rev-left rev-of-goal)
"finds n-of-S which leaves largest match of left track with current goal, so keeps record of match-size too
(find-n-for-S '(e d c b a) '(a b c d e)) => 4"
(prog((output (list 0 0)) (n-for-S 0)(match-size 0))
loop
(if (null rev-left)(return (second output)))
(setf n-for-s (+ 1 n-for-s))
(setf rev-left (rest rev-left))
(setf match-size (length (match-starts rev-left rev-of-goal)))
(if (> match-size (first output))(setf output (list match-size n-for-S)))
(go loop)))
(defun find-n-for-L(track rev-of-goal)
"computes optimal n for L move, cycling thru all values and doing temp R move after each to assess match
afterwards of left+siding with goal. (find-n-for-L '((A A) (B B C C)(A B C)) '(C B A C B A)) => 3"
(prog((output (list 0 0))(n-for-L 0)(n-for-R 0))
(setf *print-diagnostics* nil)
loop
(cond((null (second track))(setf *print-diagnostics* t)(return (second output))))
(setf n-for-L (+ 1 n-for-L))(setf track (L 1 track))
(setf n-for-R (length (match-starts (reverse (first track)) rev-of-goal))) ; computes n for R move
(if (> n-for-R (first output))(setf output (list n-for-R n-for-L)))
(go loop)))
(defun remove-from-lis(n lis)
"removes n items from front of lis"
(if (= n 0) lis
(remove-from-lis (- n 1)(rest lis))))
(defun match-starts(lis1 lis2)
"rtns a list of those items at the head of lis1 that match same sequence in lis2"
(cond((null lis1) nil)
((equal (first lis1)(first lis2))
(cons (first lis1)(match-starts (rest lis1)(rest lis2))))))
; -------------------------------------------------------------------------------------------------------------------------
; Part 6: The three basic moves on the railway track
; -------------------------------------------------------------------------------------------------------------------------
(defun S(n track)
"moves n carriages from left to Siding"
(let((output track))
(dotimes (number n output)
(setf output (1-to-siding output)))
(cond( *print-diagnostics* (terpri)(princ "S ")(princ n)(princ ": ")(princ output)))
output))
(defun R(n track)
"moves n carriages from left to right"
(let((output track))
(dotimes (number n output)
(setf output (1-to-right output)))
(cond( *print-diagnostics* (terpri)(princ "R ")(princ n)(princ ": ")(princ output)))
output))
(defun L(n track)
"moves n carriages from siding to left"
(let((output track))
(cond((> n (length (second track)))
(terpri)(princ "L ")(princ n)(princ " is impossible") nil)
(t (dotimes (number n output)
(setf output (1-to-left output)))))
(cond( *print-diagnostics* (terpri)(princ "L ")(princ n)(princ ": ")(princ output)))
output))
(defun 1-to-siding(track)
"moves one car from left to siding"
(let* ((carriage (first (reverse (first track))))
(left (rear (first track)))
(siding (cons carriage (second track)))
(right (third track)))
(list left siding right)))
(defun 1-to-right(track)
"moves one car from left to right"
(let* ((carriage (first (reverse (first track))))
(left (rear (first track)))
(siding (second track))
(right (cons carriage (third track))))
(list left siding right)))
(defun 1-to-left(track)
"moves one car from siding to front of left"
(let* ((carriage (first (second track)))
(left (append (first track) (list carriage)))
(siding (rest (second track)))
(right (third track)))
(list left siding right)))
(defun rear (train)
"rear of train on left"
(reverse (rest (reverse train))))
; -------------------------------------------------------------------------------------------------------------------------
; Part 7: Find the loop in a trace of moves returned by solve
; -------------------------------------------------------------------------------------------------------------------------
(defun find-loops(trace)
"given single trace finds loop structure provided trace is long enough, e.g.
preloop loop no-of-iterations post-loop
(find-loops '(S 4 R 1 L 1 R 2 L 2 R 3 L 3 S 6)) => (((S 4) (R (1 2) L (1 2)) 3 (S 6)))"
(prog((loop-len 4) outputs final-output)
loop
(cond ((setf outputs (m-find-loop loop-len trace))
(setf final-output (update-final-output final-output outputs))
(cond((<= (+ loop-len 2)(/ (length trace) 2))
(setf loop-len (+ loop-len 2))
(go loop))
(t (return final-output)))))))
(defun m-find-loop(loop-len trace)
"for given loop-len, rtns structure(s) with longest loops in trace
(m-find-loop 4 '(S 4 R 1 L 1 R 2 L 2 R 3 L 3 S 6)) => (((S 4)(R (1 2) L (1 2)) 3 (S 6)))"
(prog (loop-output end-output output (counter 1)(original-trace trace))
loop1
(cond((null trace)(go loop2))
((and (<= loop-len (/ (length trace) 2))
(setf loop-output (recovers-loop loop-len (list (rtn-n loop-len trace))(rtn-without-n loop-len trace))))
(setf output (append output (list (first loop-output)(second loop-output))))
(setf trace (third loop-output))(go loop1))
(t (setf output (extend-end output (list(first trace)(second trace)))) ; pre/post loop
(setf trace (cddr trace))(go loop1)))
loop2
(setf end-output (update-end-output end-output output))
(cond((< counter (/ (length original-trace) 2))
(setf trace original-trace)(setf output (list (rtn-n (* counter 2) trace)))
(setf loop-output nil trace (rtn-without-n (* counter 2) trace) counter (+ counter 1))
(go loop1))
(t (return end-output)))))
(defun recovers-loop(loop-len lis-of-iters trace)
"updates lis-of-iters iff last item in it equals first loop-len of trace, checks increments too; else nil
(recovers-loop 4 '((R 1 S 1)) '(R 1 S 1 R 1 S 1 R 2 S 2)) => ((R 1 S 1) 3 (R 2 S 2))"
(prog(iteri iterimoves iteri+1 iteri+1moves (n-of-iters 1))
loop
(setf iteri (first (last lis-of-iters)) iteri+1 (rtn-n loop-len trace))
(setf iterimoves (rtn-n-moves (/ loop-len 2) iteri) iteri+1moves (rtn-n-moves (/ loop-len 2) iteri+1))
(cond((and (or (equalp iteri iteri+1)
(equalp iterimoves iteri+1moves))
(check-increments (append lis-of-iters (list iteri+1)))) ; rtns either incr-lis or nil
(setf lis-of-iters (append lis-of-iters (list iteri+1)))
(setf n-of-iters (+ 1 n-of-iters))
(setf trace (rtn-without-n loop-len trace))
(go loop))
((> (length lis-of-iters) 1)
(return (list (check-increments lis-of-iters) n-of-iters trace))))))
(defun update-final-output(final-output outputs)
"updates final-output if nec with structures in outputs if they are shorter or equal in length"
(let ((len-final-o (length (flatten-lis (first final-output))))(len-o (length (flatten-lis (first outputs)))))
(cond((null final-output) outputs)
((< len-final-o len-o) final-output)
((= len-final-o len-o) (append final-output outputs))
(t outputs))))
(defun update-end-output (end-output output)
"compares current output with earlier one rtns shorter one"
(let ((output-len (length (flatten-lis output)))(end-len (length (flatten-lis (first end-output)))))
(cond((null end-output)(list output))
((list-equalp end-output output) end-output)
((< output-len end-len)(list output))
((= output-len end-len)(cons output end-output))
(t end-output))))
(defun extend-end(output new-end)
"replaces end of output with original + new end, e.g. (extend-end '((L 5 R 2) 3 (R 1)) '(S 1 R 3)) =>
((L 5 R 2) 3 (R 1 S 1 R 3))"
(let ((old-end (first(last output))))
(if (listp (first(last output)))
(reverse (cons (append old-end new-end)(cdr (reverse output))))
(append output (list new-end)))))
(defun check-increments(lis-of-iters)
"checks that each iter in lis-of-iters fits the required increments of its first two iters
(check-increments '((R 1 S 1) (R 2 S 2) (R 3 S 3) (R 4 S 4))) => (R (1 2) S (1 2))"
(prog(incr-lis)
loop
(cond((null (cdr lis-of-iters))(return incr-lis))
((null incr-lis)(setf incr-lis (detect-var (first lis-of-iters)(second lis-of-iters)))
(go loop))
((equalp incr-lis (match-increments incr-lis (first lis-of-iters)(second lis-of-iters)))
(setf lis-of-iters (cdr lis-of-iters))
(go loop)))))
(defun detect-var(it-1 it-2)
"rtns values of variables in 2 iterations of loop, else loop unchanged
(detect-var '(R 1 S 2 L 1 R 2) '(R 1 S 3 L 1 R 2)) => (R 1 S (2 3) L 1 R 2)"
(cond((null it-1) nil)
((equal (first it-1)(first it-2))(cons (first it-1)(detect-var (rest it-1)(rest it-2))))
((numberp (first it-1))
(cons (list (first it-1)(first it-2))(detect-var (rest it-1)(rest it-2))))
(t (print '(Error in detection of loops)))))
(defun match-increments(incr-lis iteri iteri+1)
"rtns full incr-lis iff it predicts correct values via incr-arith of iter-ith
so calling fn tests whether what it rtns = incr-lis in full
(match-increments '(R (1 2) S (1 2)) '(R 2 S 2) '(R 3 S 3)) => (R (1 2) S (1 2))"
; (princ "incr-lis ")(princ incr-lis)(princ " iteri ")(princ iteri+1)(terpri)
(cond((null incr-lis) nil)
((or (equalp (first incr-lis)(first iteri+1))
(and (listp (first incr-lis))
(equalp (+ (incr-arith (first incr-lis))(first iteri))(first iteri+1))))
(cons (first incr-lis)(match-increments (rest incr-lis)(rest iteri)(rest iteri+1))))))
(defun incr-arith(lis)
"uses list such (3 2), which rtns -1, from incr-lis to compute value needed to make a linear sequence"
(let ((incr (- (second lis)(first lis))))
incr))
(defun list-equalp(lis output)
"rtns output if it occurs in lis"
(dolist (itm lis)
(if (equalp itm output)(return output))))
(defun flatten-lis(lis)
"ok removes structure and rtns lis of all atoms in lis"
(cond((null lis) nil)
((atom lis)(list lis))
(t (append (flatten-lis (car lis))(flatten-lis (cdr lis))))))
(defun rtn-n(n lis)
"rtns n items from front of lis (rtn-n 2 '(a b c)) => (A B)"
(if (or (< (length lis) n)(<= n 0))
nil
(cons (first lis)(rtn-n (- n 1)(rest lis)))))
(defun rtn-n-moves(n lis)
"rtns n move-symbols from front of lis (rtn-n-moves 2 '(3 L 1 R 5 S 2)) => (L R)"
(if (or (> n (/ (length lis) 2))(<= n 0))
nil
(if (numberp (first lis))
(rtn-n-moves n (rest lis))
(cons (first lis)(rtn-n-moves (- n 1)(cddr lis))))))
(defun rtn-without-n(n lis)
"rtns lis with n items removed from front (rtn-without-n 2 '(a b c)) => (C)"
(if (or (<= n 0))
lis
(rtn-without-n (- n 1)(rest lis))))
; -------------------------------------------------------------------------------------------------------------------------
; Part 8: Extracts structure for for-loops from loops derived from two traces of different lengths
; -------------------------------------------------------------------------------------------------------------------------
(defun select-one-loop(structures)
"rtns a single loop-structure, printing message if more than one"
(cond((> (length structures) 1)
(terpri)(princ "More than one possible list structure of equivalent complexity: ")
(princ structures)(terpri)))
(first structures))
(defun find-struct (two-loops)
"rtns structure for programming, e.g. (FIND-STRUCT '(((S 3 R 1) (L 1 R 1) 3) ((S 4 R 1) (L 1 R 1) 4))) =>
(STATIC (4 5) (1 -1) (S 3 R 1) (S 4 R 1) (L 1 R 1) NIL NIL)"
(let* ((short-loop (first two-loops))(long-loop (second two-loops))
(loop&rest-s (loop+rest short-loop))(loop&rest-l (loop+rest long-loop))
(pre-loop-s (pre-loop short-loop))(pre-loop-l (pre-loop long-loop))
(loop-s (first loop&rest-s))(loop-l (first loop&rest-l))
(post-loop-s (post-loop loop&rest-s))(post-loop-l (post-loop loop&rest-l)))
(prog()
(if (different-loops pre-loop-s pre-loop-l loop-s loop-l post-loop-s post-loop-l)
(return nil))
(let* ((len-lis (list (n-of-moves short-loop)(n-of-moves long-loop)))
(n-of-iters-s (second loop&rest-s))(n-of-iters-l (second loop&rest-l))
(output (list len-lis
(solve-eq len-lis (list n-of-iters-s n-of-iters-l)) ; moved position from below
pre-loop-s pre-loop-l
(dyn-parameters loop-s loop-l n-of-iters-s n-of-iters-l)
post-loop-s post-loop-l)))
(if (equal loop-s loop-l)
(return (cons 'static output))
(return (cons 'dynamic output)))))))
(defun different-loops (pre-loop-s pre-loop-l loop-s loop-l post-loop-s post-loop-l)
"test for comparable structures for the two instances of a problem"
(cond((null loop-s)(princ " Shorter input contains no loop. Please try again with a longer input.") t)
((and (= (length pre-loop-s)(length pre-loop-l))
(= (length loop-s)(length loop-l))
(= (length post-loop-s)(length post-loop-l))) nil)
(t (terpri)(princ "The loop structure of the two problems differs. Please try using a longer example.") t)))
(defun loop+rest(structure)
"Rtns loop and what follows it from structure"
(cond((null structure) nil)
((and (listp (first structure))(numberp (second structure))) structure)
(t (loop+rest (rest structure)))))
(defun n-of-moves(struct)
"sums no of R moves in struct, multiply no in loop by no of iterations, e.g.
(n-of-moves '((R 1 L 2)(R 2 L 3) 2 (L 3 R 4))) => 9"
(cond((null struct) 0)
((and (listp (first struct))(numberp (second struct)))
(+ (* (sum-of-rs (first struct))(second struct))(n-of-moves (cddr struct))))
(t (+ (sum-of-rs (first struct))(n-of-moves (cdr struct))))))
(defun sum-of-rs(lis)
"sums no of cars after 'R in op-list, which equals length of train"
(cond((null lis) 0)
((equal (first lis) 'R)(+ (second lis)(sum-of-rs (rest lis))))
(t (sum-of-rs (rest lis)))))
(defun pre-loop(struct)
"rtns first.struct iff pre-loop, e.g. (pre-loop '((R 1 S 8 R 2 L 5) (R 2 S (3 2) R 1 L (4 3)) 3 (R 3)))"
(if (and (first struct)(not (numberp (second struct))))
(first struct)))
(defun dyn-parameters(loop-s loop-l n-of-iters-s n-of-iters-l)
"converts loop-s and loop-n into a single loop with dynamic parameters, e.g.
(dyn-parameters '(R 1 S (4 2) R 1 L (4 2)) '(R 1 S (6 4) R 1 L (6 4)) 2 3) =>
(R 1 S (2 -2 2) R 1 L (2 -2 2)). Rtns static loop unchanged"
(cond((null loop-s) nil)
((or (numberp (first loop-s))(atom (first loop-s)))
(cons (first loop-s)
(dyn-parameters (cdr loop-s)(cdr loop-l) n-of-iters-s n-of-iters-l)))
(t (cons (append (solve-triple-eq (first loop-s)(first loop-l) n-of-iters-s n-of-iters-l))
(dyn-parameters (cdr loop-s)(cdr loop-l) n-of-iters-s n-of-iters-l)))))
(defun solve-triple-eq (operands-s operands-l n-s n-l)
"solves 3 simultaneous equations to yield operand values for variable moves in dynamic loops, i.e.,
a, b, and c, in no-of-operands = a(n-of-iters) + b(ith-iteration) + c
rational converts number to rational for use in dotimes etc "
(let ((equation-s-1 nil)(equation-s-2 nil)(equation-l-1 nil)
(solution nil)(offset 1))
(setf equation-s-1 (list n-s 1 offset (first operands-s)))
(setf equation-s-2 (list n-s 2 offset (second operands-s)))
(setf equation-l-1 (list n-l 1 offset (first operands-l)))
(setf solution (solve-matrix (make-array '(3 4) :initial-contents
(list equation-s-1 equation-s-2 equation-l-1))))
(list (rational (aref solution 0))(rational (aref solution 1))(rational (aref solution 2)))))
(defun solve-eq(len-lis n-lis)
"solves for a and b in two simultaneous linear equations, n = a.len + b,
len-lis = lengths of two trains, and n-lis respective no. of iterations
(solve-eq '(4 6) '(1 2) => (1/2 -1) (solve-eq '(9 12) '(1 2)) "
(let* ((len1 (first len-lis))(len2 (second len-lis))
(n1 (first n-lis))(n2 (second n-lis))
(a (/ (- n2 n1)(- len2 len1)))
(b (- n1 (* a len1))))
(list a b)))
(defun post-loop(lis)
"Rtns list following number denoting number of iterations in lis"
(cond((null lis) nil)
((numberp (first lis))(cadr lis))
(t (post-loop (rest lis)))))
; -------------------------------------------------------------------------------------------------------------------------
; Part 9: Automated programming
; -------------------------------------------------------------------------------------------------------------------------
#|
The functions that construct functions
(DEFUN RIFF-IN (TRACK) <- function-header
(LET* ((LEN (LENGTH (FIRST TRACK))) (N-OF-S (+ (* 1/2 LEN) -1)) (DECREMENT 1)) <- dynamic-let
(LOOP WHILE (> N-OF-S 0) <- static-loop-code
DO (SETF TRACK (R 1 TRACK)) <- sequence-code
(SETF TRACK (S N-OF-S TRACK))
(SETF TRACK (R 1 TRACK))
(SETF TRACK (L N-OF-S TRACK))
(SETF N-OF-S (- N-OF-S DECREMENT)))
(SETF TRACK (R 2 TRACK)) <- sequence-code
TRACK))
(AUTO-DYNAMIC-WHILE 'RIFF-IN '(((A B C D E F) NIL NIL) (NIL NIL (A D B E C F)))
'(((A B C D E F G H) NIL NIL) (NIL NIL (A E B F C G D H)))
'((6 8) (1/2 -1) NIL NIL (R 1 S (1 -1 1) R 1 L (1 -1 1)) (R 2) (R 2))
'((R 1 S 3 R 1 L 3 R 1 S 2 R 1 L 2 R 1 S 1 R 1 L 1 R 2) (R 1 S 2 R 1 L 2 R 1 S 1 R 1 L 1 R 2))) |#
(defun auto-program(name loop-type lis-structure track-1 track-2 two-traces)
"calls auto-dynamic-for, auto-dynamic-while or auto-static depending on lis-structure"
(if (equal (car lis-structure) 'dynamic)
(if (equal loop-type 'for)
; auto-dynamic-for(name loop-type lis-structure
(auto-dynamic-for name loop-type (rest lis-structure))
(auto-dynamic-while name track-1 track-2 (rest lis-structure) two-traces))
(auto-static name loop-type track-1 track-2 (rest lis-structure) two-traces)))
(defun auto-static(name loop-type track-1 track-2 lis-structure two-lists)
"converts static lis-structure into code for fn with for-loop & fn with while-loop"
(let ((len-lis (first lis-structure))
(parameters (second lis-structure))
(pre-loop-1 (third lis-structure))
(pre-loop-2 (fourth lis-structure))
(loop-lis (fifth lis-structure))
(post-loop-1 (sixth lis-structure))
(post-loop-2 (seventh lis-structure))
(continue-condn nil)
(output-fn nil))
(princ "The static loop structure is: ")(princ lis-structure)
(if pre-loop-1 (setf output-fn
(append output-fn (sequence-code len-lis pre-loop-1 pre-loop-2))))
(cond( loop-lis
(if (equal loop-type 'while)
(setf continue-condn
(call-simulate-loops track-1 track-2 two-lists lis-structure)))
(setf output-fn (append output-fn
; (static-loop-code loop-type continue-condn)
(list (append (static-loop-code loop-type continue-condn)
(cons 'do (sequence-code len-lis loop-lis loop-lis))))))))
(if post-loop-1
(setf output-fn (append output-fn (sequence-code len-lis post-loop-1 post-loop-2))))
(setf output-fn (append output-fn (list 'track)))
(function-header name loop-type len-lis loop-lis parameters output-fn)))
(defun auto-dynamic-for(name loop-type lis-structure)
"constructs function embodying dynamic for-loop"
(let* ((len-lis (first lis-structure))
(parameters (second lis-structure))
(pre-loop-1 (third lis-structure))
(pre-loop-2 (fourth lis-structure))
(loop-lis (fifth lis-structure))
(post-loop-1 (sixth lis-structure))
(post-loop-2 (seventh lis-structure))
(continue-condn nil)
(output-fn nil))
(terpri)(princ "The dynamic loop structure is: ")(princ lis-structure)
(if pre-loop-1 (setf output-fn
(append output-fn (sequence-code len-lis pre-loop-1 pre-loop-2))))
(cond((equal loop-type 'for)
(setf output-fn
(append output-fn ; (static-loop-code loop-type continue-condn)
(list (append (static-loop-code loop-type continue-condn)
(cons 'do (sequence-code len-lis loop-lis loop-lis))))))) )
(if post-loop-1
(setf output-fn (append output-fn
(sequence-code len-lis post-loop-1 post-loop-2))))
(setf output-fn (append output-fn (list 'track)))
(function-header name loop-type len-lis loop-lis parameters output-fn)))
(defun auto-dynamic-while(name track-1 track-2 lis-structure two-lists)
"constructs fn embodying dynamic while-loop"
(if (> (length (first two-lists))(length (second two-lists)))
(setf two-lists (reverse two-lists)))
(let* ((short-loops (car (loop+rest (select-one-loop (find-loops (first two-lists))))))
(long-loops (car (loop+rest (select-one-loop (find-loops (second two-lists)))))))
(terpri)(princ "lis-structure ")(princ lis-structure)(terpri)
(let* ((variable-move-s (first (find-variable-operands short-loops)))
(len-lis (first lis-structure))
(parameters (second lis-structure))
(pre-loop-1 (third lis-structure))
(pre-loop-2 (fourth lis-structure))
(post-loop-1 (sixth lis-structure))
(post-loop-2 (seventh lis-structure))
(let-line (dynamic-let-instr short-loops))
(dynamic-var (make-atom 'n-of- variable-move-s))
(continue-condn (call-simulate-loops track-1 track-2 two-lists lis-structure))
(n-loop-lis (map-loop-lis short-loops))(output-fn nil))
(if pre-loop-1 (setf output-fn
(append output-fn (sequence-code len-lis pre-loop-1 pre-loop-2))))
(setf output-fn (append output-fn
(list (append (static-loop-code 'while continue-condn)
(cons 'do (append (sequence-code len-lis n-loop-lis n-loop-lis)
(add-decrements n-loop-lis)))))))
(if post-loop-1
(setf output-fn (append output-fn
(sequence-code len-lis post-loop-1 post-loop-2))))
(setf output-fn (append output-fn (list 'track)))
(function-header name 'while-dynamic len-lis long-loops parameters output-fn))))
(defun map-loop-lis(loop-lis)
"rtns variables in place of moves with varying numbers of operands, e.g.,
(map-loop-lis '(S (5 3) R 1 L (5 3) R 1)) => (S N-OF-S R 1 L N-OF-L R 1)"
(cond((null loop-lis) nil)
((atom (second loop-lis))(cons (first loop-lis)(cons (second loop-lis)(map-loop-lis (cddr loop-lis)))))
(t (cons (first loop-lis)(cons (make-atom 'n-of- (first loop-lis))(map-loop-lis (cddr loop-lis)))))))
(defun function-header(name loop-type len-lis loop-lis parameters output-fn)
"constructs header for function, i.e., the let condition(s)"
(let ((header (list 'defun name (list 'track))))
(if (and (first parameters)(equal loop-type 'for))
(append header
(list (cons 'let* (cons
(list (list 'len (list 'length (list 'first 'track)))
(list 'n-of-iters (list '+ (list '* (first parameters) 'len)(second parameters))))
output-fn))))
(if (equal loop-type 'while-dynamic)
(append header
(list (cons 'let* (cons (make-let-values len-lis loop-lis) output-fn))))
(append header
(list (cons 'let (cons
(list (list 'len (list 'length (list 'first 'track))))
output-fn))))))))
(defun make-let-values(len-lis loop-lis-s)
"constructs complete let line for dynamic loop functions"
(let ((front (list 'len (list 'length (list 'first 'track)))))
(prog(output)
loop
(cond((null loop-lis-s)(return (cons front output)))
((listp (second loop-lis-s))
(setf output (append output
(dynamic-let len-lis (first loop-lis-s)(second loop-lis-s))))))
(setf loop-lis-s (cddr loop-lis-s))
(go loop))))
(defun dynamic-let(len-lis move op-s)
"makes initial let* value of dynamic variable and its decrement on each increment"
(let((parameters (solve-eq len-lis (reverse op-s))))
(list
(list (make-atom 'n-of- move)(list '+ (list '* (first parameters) 'len)(second parameters)))
(list (make-atom 'decrement- move)(- (first op-s)(second op-s))))))
(defun dynamic-let-instr(loop-lis)
"(dynamic-let-instr '(R 1 S (1/2 -1 1) R 1 L (1/3 -1 1))) =>
((N-OF-S (+ (* 1/2 LEN) -1)) (N-OF-L (+ (* 1/3 LEN) -1)) (DECREMENT 1))"
(prog ((output nil)(move nil)(formula nil))
loop
(cond((null loop-lis)(return (append output (list (list 'decrement (third formula))))))
((and (listp (second loop-lis))
(or (null formula)(not(equal formula (second loop-lis)))))
(setf move (first loop-lis))
(setf formula (second loop-lis))
(setf output (append output
(list (list (make-atom 'n-of- move)
(list '+ (list '* (first formula) 'len)(second formula))))))))
(setf loop-lis (cddr loop-lis))
(go loop)))
(defun make-atom(atom-1 atom-2)
"convert 'n-of- and 's into n-of-s"
(let ((str-1 (symbol-name atom-1))(str-2 (symbol-name atom-2)))
(read-from-string (concatenate 'string str-1 str-2))))
(defun static-loop-code(loop-type continue-condn)
"constructs the line setting up a static loop"
(cond((equal loop-type 'for)
(list 'loop 'for 'i 'from 1 'to 'n-of-iters))
((or (equal loop-type 'while)
(equal loop-type 'while-dynamic))
(list 'loop 'while continue-condn))
(t (princ "Error - unclear loop-type")(terpri))))
(defun sequence-code(len-lis sequence-1 sequence-2)
"calls convert-op to construct code for ops not in a loop, two deletes decrement from lis of variables
(sequence-code '(6 8) '(R 1 S (1 -1 1) R 1 L (1 -1 1)) '(R 1 S (1 -1 1) R 1 L (1 -1 1)))"
(if (null sequence-1)
nil
(cons (convert-op len-lis sequence-1 sequence-2)
(sequence-code len-lis (rtn-without-n 2 sequence-1)(rtn-without-n 2 sequence-2)))))
(defun add-decrements(sequence)
"adds 'decrement-s to setf instructions, e.g. (add-decrements '(R 1 S N-OF-S R 1 L N-OF-S)) =>
((SETF N-OF-S (- N-OF-S DECREMENT-S)) (SETF N-OF-S (- N-OF-S DECREMENT-L))) "
(if (null sequence)
nil
(if (or (numberp (second sequence))(listp (second sequence)))
(add-decrements (rtn-without-n 2 sequence))
(cons (list 'setf (second sequence) (list '- (second sequence)(make-atom 'decrement- (first sequence))))
(add-decrements (rtn-without-n 2 sequence))))))
(defun convert-op(len-lis op1 op2)
"converts op to lisp, if n varies calls solve-eq for values of a and b, e.g.:
(convert-op '(6 8) '(S 2) '(S 3)) => (SETF TRACK (S (+ (* 1/2 LEN) -1) TRACK))"
(if (numberp (second op1))
(if (equal (second op1)(second op2))
(code-op op1)
(code-op (list (first op1)(solve-eq len-lis (list (second op1)(second op2))))))
(code-op op1)))
(defun code-op(op-n)
"takes op and n, and rtns code for them"
(let ((op (first op-n))(n (second op-n)))
(cond((equal op 'R)(setf op 'R))
((equal op 'S)(setf op 'S))
((equal op 'L)(setf op 'L))
(t (princ "Unknown operator assigned to code-op of ")(princ op)(terpri)))
(cond((or (numberp n)(atom n))
(list 'setf 'track (list op n 'track)))
((= (length n) 2)
(list 'setf 'track (list op (list '+ (list '* (first n) 'len) (second n))
'track)))
((= (length n) 3) ; dynamic for-loop move
(list 'setf 'track
(list op (list '+ (list '* (first n) 'n-of-iters)
(list '* 'i (second n))
(third n))
'track))))))
(defun call-simulate-loops(track-1 track-2 two-traces lis-structure)
"calls simulate-loops to construct while-loop"
(if (> (length (first two-traces))(length (second two-traces)))
(setf two-traces (reverse two-traces)))
(let ((halt-cond (simulate-loops (first track-1)(first track-2) two-traces lis-structure)))
(terpri)(princ "Simulations show that loop should continue while ")
(princ halt-cond)
halt-cond))
(defun simulate-loops(track-1 track-2 two-traces structure)
"uses traces of moves to simulate a sequence of operations and assesses while conditions"
(let* ((len-1 (length (second (reverse structure)))) ; length of post-loop in list-of-ops
(len-2 (length (first(reverse structure))))
(pre-loop-1 (third structure))
(pre-loop-2 (fourth structure))
(trace-to-endloop-1 (reverse (rtn-without-n len-1 (reverse (first two-traces)))))
(trace-to-endloop-2 (reverse (rtn-without-n len-2 (reverse (second two-traces))))))
(assess-while-condns (append (simul track-1 pre-loop-1 trace-to-endloop-1)
(simul track-2 pre-loop-2 trace-to-endloop-2)))))
(defun assess-while-condns(tracks)
"finds what is common to two cases in which a loop ends and NOT to start of loop"
(let ((left-end-1 (length(first(first tracks)))) (siding-end-1 (length(second(first tracks))))
(left-start-1 (length(first(second tracks))))(siding-start-1 (length(second(second tracks))))
(left-end-2 (length(first(third tracks)))) (siding-end-2 (length(second(third tracks)))))
(cond((and (= left-end-1 left-end-2)(not (= left-end-1 left-start-1)))
(list '> '(length (first track)) left-end-1))
((and (= siding-end-1 siding-end-2)(not (= siding-end-1 siding-start-1)))
(list '> '(length (second track)) siding-end-1))
(t (princ "No halt for while-loop detected ")(terpri)))))
(defun simul(start-track pre-loop trace-to-end-loop)
"simul records that start conditions of each loop and the exit condition"
(let ((trace-to-end-loop (rtn-without-n (length pre-loop) trace-to-end-loop)))
(setf *print-diagnostics* t)
(setf start-track (simul-sequence start-track pre-loop))
(list (simul-sequence start-track trace-to-end-loop) start-track)))
(defun simul-sequence(start-track trace)
"simulates the moves in trace"
(prog()
loop
(cond((null trace)(return start-track))
(t (setf start-track (funcall (first trace)(second trace) start-track))
(setf trace (cddr trace))
(go loop)))))
(defun find-variable-operands(loop)
"scans loop for moves with variables as operands, and rtns list of sort-of-move and parameters"
(cond((null loop) nil)
((and (not(numberp (first loop)))(not(numberp (second loop))))
(cons (first loop)(cons (second loop)(find-variable-operands (cddr loop)))))
(t (find-variable-operands (cddr loop)))))
; -------------------------------------------------------------------------------------------------------------------------
; Part 10: Translates the program's while-functions into everyday language
; -------------------------------------------------------------------------------------------------------------------------
(defun translate(fn)
"translates the initial let settings for dynamic while-loops, calls transl"
(let ((new-fn (cdr (cadddr fn))))
(if (> (length (first new-fn)) 1)
(translate-let (rest (first new-fn))))
(transl (cdr new-fn))))
(defun transl(fn)
"translates pre-loop actions, while loop, and post-loop, recursively"
(cond((null fn) (terpri) t)
((atom (first fn))(transl (rest fn)))
((equal (caar fn) 'loop)(trans-while (first fn))
(transl (rest fn)))
((equal (caar fn) 'setf)(print-string (lis-action (first fn)))
(transl (rest fn)))
(t (print-string '(Clause in function that cannot be translated)))))
(defun translate-let(lis)
"(translate-let '((N-OF-S (+ (* 1/2 LEN) -1)) (DECREMENT 1))) =>
set the number of operands to be dynamically moved, n-of-s, to half the length of the train minus one
set the decrement to one"
(prog(first-lis second-lis output)
loop
(setf first-lis (first lis) second-lis (second lis))
(cond((null lis)(return output))
(t
(print-first-clause '(set the number of operands to be dynamically moved))
(print-later-clause (list (first first-lis)))
(princ " to")
(print-last-clause (trans-arith (second first-lis)))
(print-string (append (list 'set 'the)(list (first second-lis)) '(to) (trans-num (second second-lis))))
(setf lis (cddr lis))(go loop)))))
(defun trans-while(lis)
"calls lis-while-condition for the condition, and trans-action for the actions within it"
(cond((null lis) nil)
((not (listp (first lis)))(trans-while (rest lis)))
((or (equal (first (first lis)) '>)
(equal (first (first lis)) '<))
(print-first-clause (lis-while-condition (first lis)))
(trans-while (rest lis)))
((equal (first (first lis)) 'setf)
(terpri)(princ " ")
(if (> (length lis) 1)
(print-later-clause (lis-action (first lis)))
(print-last-clause (lis-action (first lis))))
(trans-while (rest lis)))
(t (trans-while (rest lis)))))
(defun lis-while-condition(case)
"makes lis of the while condition (lis-while-condition '(> N-OF-S 0)) => (WHILE N-OF-S IS MORE THAN ZERO)
(lis-while-condition '(> (LENGTH (FIRST TRACK)) 2))=>'(WHILE THERE ARE MORE THAN TWO CARS ON THE LEFT TRACK)"
(let ((pred (first case))(part nil)
(num (trans-number (first(last case))))(output nil))
(cond((atom (second case))
(cond((equal pred '>)
(setf output (list 'while (second case) 'is 'more 'than (first (trans-num (third case))))))
((equal pred '<)
(setf output (list 'while (second case) 'is 'less 'than (first (trans-num (third case))))))))
(t (setf part (cadadr case))
(cond((equal pred '>)(setf output (append '(while there are more than) num)))
((equal pred '<)(setf output (append '(while there are less than) num))))
(cond((equal part '(first track))(setf output (append output '(on the left track))))
((equal part '(second track))(setf output (append output '(on the siding)))))))
output))
(defun lis-action(instr)
"constucts lis of independent actions and those in while loops '(SETF N-OF-S (- N-OF-S DECREMENT))"
(let* ((lis (third instr))(op (first lis))(formula (second lis)))
(cond((listp formula)(append '(move)(trans-arith formula)(trans-op op)))
((numberp formula)(append '(move)(trans-number formula)(trans-op op)))
((atom formula)
(if (equal (second instr) 'track)
(append (list 'move formula 'cars)(trans-op op))
(trans-update-variable lis)))
(t '(unknown description)))))
(defun trans-update-variable(lis)
"(trans-update-variable '(- N-OF-S DECREMENT)) => take decrement from n-of-s"
(let ((op (first lis))(var (second lis))(constant (third lis)))
(if (equal op '-)
(list 'take constant 'from var))))
(defun trans-arith(formula)
"translates arithmetic formulas using trans-number and trans-product
(+ (* 1 LEN) -1) => one less than the cars
(+ (* 1 N-OF-ITERS) (* I -1) 1) => one times the number of iterations minus the ith iteration"
(let ((prod (second formula))(constant (third formula)))
(cond((listp constant)
(append '(a number of cars dependent on iterations) constant)(trans-product prod))
((= constant 0) (trans-product prod))
((< constant 0) (append (trans-num constant) '(less than)(trans-product prod)))
((> constant 0) (append (trans-num constant) '(more than)(trans-product prod))))))
(defun trans-product(formula)
"translates formulas for a product"
(cond((null formula) nil)
((and (equal (first formula) '*)(= (second formula) 1)) '(the cars))
((and (equal (first formula) '*)(= (second formula) 1/2)) '(half the cars))
((and (equal (first formula) '*)(= (second formula) 1/3)) '(a third of the cars))
((and (equal (first formula) '*)(= (second formula) 2/3)) '(two thirds of the cars))
((and (equal (first formula) '*)(numberp (second formula)))
(cons (second formula) '(the cars)))
(t (print '(error in translating into English)))))
(defun trans-op(op)
"translates the three sorts of move"
(cond((equal op 'R) '(to the right track))
((equal op 'S) '(to the siding))
((equal op 'L) '(to the left track))
(t (print '(Error in English translation - unknown move)))))
(defun trans-number(num)
(if (= num 1)
(append (trans-num num) '(car))
(append (trans-num num) '(cars))))
(defun trans-num(num)
(cond((= num 0) '(zero))
((= num 1) '(one))
((= num 2) '(two))
((= num 3) '(three))
((= num 4) '(four))
((= num 5) '(five))
((= num 6) '(six))
((= num 7) '(seven))
((= num 8) '(eight))
((= num 9) '(nine))
((= num 10) '(ten))
((= num -1) '(one))
((= num -2) '(two))
((= num -1/2) '(half))
(t '(many))))
(defun print-string (lis)
"converts a list into a string, capitalizing initial letter of first word, adding period"
(princ (concatenate 'string (string-capitalize (atm-to-string (car lis)))(conversion (cdr lis))))
(terpri))
(defun print-first-clause(lis)
"converts lis to a string, capitalizing initial letter of first word, adds comma"
(princ (concatenate 'string (string-capitalize (atm-to-string (car lis)))(clause-conversion (cdr lis)))))
(defun print-later-clause(lis)
"converts lis to a string, adds comma"
(princ (concatenate 'string (clause-conversion lis))))
(defun print-last-clause(lis)
"converts lis to a string, adds period"
(princ (concatenate 'string (conversion lis)))
(terpri))
(defun clause-conversion(lis)
(if (null lis) ","
(concatenate 'string (atm-to-string (car lis))(clause-conversion (rest lis)))))
(defun conversion(lis)
(if (null lis) "."
(concatenate 'string (atm-to-string (car lis))(conversion (cdr lis)))))
(defun atm-to-string(atm)
(concatenate 'string " " (string-downcase (symbol-name atm))))
; -------------------------------------------------------------------------------------------------------------------------
; Part 11: Matrix algebra for solving three simultaneous equations
; -------------------------------------------------------------------------------------------------------------------------
; From Elephant System Original Version, Copyright © 2004 Ben Lee and Andrew Blumberg.
; Version 0.5, Copyright © 2006 Robert L. Read.
; Versions 0.6-0.9, Copyright © 2006-2007 Ian Eslick and Robert L. Read
; The Elephant System is licensed under the GNU LGPL (version 2.1, 1999).
(defun num-rows (matrix)
"Return the number of rows of a matrix"
(array-dimension matrix 0))
(defun num-cols (matrix)
"Return the number of rows of a matrix"
(array-dimension matrix 1))
(defun copy-matrix (matrix)
"Return a copy of the matrix."
(let* ((rows (num-rows matrix))
(cols (num-cols matrix))
(copy (make-array (list rows cols))))
(dotimes (row rows copy)
(dotimes (col cols)
(setf (aref copy row col) (aref matrix row col))))))
(defun print-matrix (matrix &optional (destination t) (control-string "~20S"))
"Print a matrix. The optional control string indicates how each
entry should be printed."
(let ((rows (num-Rows matrix))
(cols (num-Cols matrix)))
(dotimes (row rows)
(format destination "~%")
(dotimes (col cols)
(format destination control-string (aref matrix row col))))
(format destination "~%")))
(defun eliminate-matrix (matrix rows cols)
"Gaussian elimination with partial pivoting.
Evaluated for side effect. A return value of :singular indicates the
matrix is singular (an error). rotatef is a macro"
(let ((max 0))
(loop for i below rows
do (setf max i)
do (loop for j from (1+ i) below rows
do (when (> (abs (aref matrix j i))
(abs (aref matrix max i)))
(setf max j)))
do (when (zerop (aref matrix max i))
(return-from eliminate-matrix :singular))
do (loop for k from i below cols
do (rotatef (aref matrix i k) (aref matrix max k)))
do (loop for j from (1+ i) below rows
do (loop for k from (1- cols) downto i
do (setf (aref matrix j k)
(- (aref matrix j k)
(* (aref matrix i k)
(/ (aref matrix j i)
(aref matrix i i)))))
)))
matrix))
(defun substitute-matrix (matrix rows cols)
(let ((temp 0.0)
(x (make-array rows :initial-element 0)))
(loop for j from (1- rows) downto 0
do (setf temp 0.0)
do (loop for k from (1+ j) below rows
do (incf temp (* (aref matrix j k) (aref x k))))
do (setf (aref x j) (/ (- (aref matrix j (1- cols)) temp)
(aref matrix j j))))
x))
(defun solve-matrix (matrix &optional (destructive nil) print-soln)
"Solve a matrix using Gaussian elimination
Matrix must be N by N+1
Assume solution is stored as the N+1st column of the matrix"
(let ((rows (num-rows matrix))
(cols (num-cols matrix))
(result (if destructive matrix (copy-matrix matrix))))
(unless (= (1+ rows) cols)
(error "Ill formed matrix"))
(cond ((eq :singular (eliminate-matrix result rows cols)))
(T (let ((soln (substitute-matrix result rows cols)))
(when print-soln
(loop for i below rows
do (format t "~% X~A = ~A" i (aref soln i))))
soln)))))
;;; End of file