#|
Circuits is a program that tries tries to reverse engineer electrical circuits
Copyright (C) Philip N. Johnson-Laird
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,
write to the Free Software Foundation, Inc., 51 Franklin Street,
Fifth Floor, Boston, MA 02110-1301, USA.
;;;;; Part 0: A description of the program
The program tries to reverse engineer simple electrical circuits
in the sort of way in which Dr. N.Y. Louis Lee discovered naive human reasoners
do - see Lee and Johnson-Laird, A theory of reverse engineering.
Version 6 rethinks the building of basic circuits so that it is done
without the constraint of a fixed minimum number of wires needed
for solution. Instead, it fixes a maximum number before the program
abandons a circuit. This maximum was determined by Dr. Lee in his
empirical studies as approximately 6-8.
1. The program represents circuits in the following sort of way.
A circuit for 'or else' with the convention that horizontal position = 1 means that switch
is closed:
S1 S2
d f g end
o---o<- o---o
o---o ->o---o
st b c e
The list structure for this circuit is:
((start b)(b c (d)) (c e) (d f) (g f (e)) (g end))
wire switch wire wire switch wire from
from from from g to end
start to b c to e d to f
When first switch is up:
'((start b)(b d (c))(d f)((e) f g)(g end))
When second switch is down
'((start b)(b c (d))(c e)((f) e g)(g end))
In other words, current flows only from elements in the basic
list, i.e., from b to c in a switch such as '(b c (d))
There is no need to label switches as such.
The set of tactical moves contains three options:
1. wiring up start or end to terminal on a switch or vice versa,
2. wiring a terminal on one switch to one on another switch,
3. wiring a wire to wire in order to make a T-junction.
This last operation yields a loose end, which itself can be wired up
according to one of the three options.
1. To explore the assembly of circuits
Suppose we have two switches, the two terminals above,
and many pieces of wire. A random procedure chooses
at random one terminal and one other terminal and interconnects
them with wire.
We need to add constraints on choose
* Don't wire a terminal to itself
predicate that tests for a component such as: (a a)
* Don't wire one terminal on a switch to another on the same switch
predicate that tests for components such as: (f g (h)) (f g)(f h)(g h)
When the program generates each circuit at random for 'and' circuit with
just one constraint: that it adds only three wires -- the correct number --
it generates many nonsensical circuits. It is given as input: the start terminal,
the end terminal, and two switches:
((START) (A B (C)) (D E (F)) (END))
It then chooses three wires at random, such as:
((END (C)) (START END) ((F) (F)) (START) (A B (C)) (D E (F)) (END))
where
1. (START END) is a direct connection between the start and end terminals,
2. ((F)(F)) is a wire from F on the second switch to itself
Another example:
((START END) (A (C)) ((C) E) (START) (A B (C)) (D E (F)) (END))
where
3. (A (C)) is wire from one terminal on a switch to another terminal on the
same switch. Analogous nonsensical outputs include cases in which the same
wire is added twice to a circuit:
4. ((START START)(START START) ...)
A wire and its converse are both added to a circuit:
5. ((START D)(D START) ...)
Hence, given that the initial circuit has 8 terminals, there are 64 possible wirings,
and 64^3 = 262,144 possible wirings. Some possible solutions are, e.g.:
((START)(A START)(A B (C))(E B)(D E (F))(END D)(END))
((START)(B START)(A B (C))(A D)(D E (F))(END E)(END))
In fact, the order of the two switches (a b (c)) and (d e (f)) is immaterial,
and so is their orientation -- the start can be wired to a or b, and then the other
terminal can be wired to either d or e. Hence, there are 8 different configurations
that solve the problem:
o--ab--cd--o
o--ab--dc--o
o--ba--cd--o
o--ba--dc--o
and then the four analogues in which the first switch on the left is cd. Each of these
configurations can be described in eight logically equivalent ways (two ways for each wire).
Hence, there are 64 ways in which the algorithm can solve the problem. Hence, the
chance probability of a solution is 84/84^3 = 1/7056. The moral is that unconstrained
neo-Darwinian algorithm is psychologically out of the question as a method for solving
this problem.
i. Choose something from domain at random, e.g., (b c)
ii. Choose something else from domain at random (no replacement).
iii. Choose terminal from FIRST at random, and choose terminal from SECOND
at random.
iv. Wire them up.
Two moves in the direction of psychological plausibility:
1. Acquire knowledge of local constraints:
i. Don't have direct wire from start to end (unless light is always on)
ii. Don't wire a terminal to itself.
iii. Don't wire one terminal on a switch to another terminal on a switch -- that's what
the switch itself does.
iv. Don't add a wiring that is already in the domain -- no need for two instances of the
same wiring.
v. Don't add a wiring if its converse is already in the domain -- wires are symmetric in
their effects.
;;;;; Part 1: A description of the functional structure of the program
Functional structure of the code
1. (test-tote *domain-two* *target-and* 3 5000 *local-constraints*) calls tote 5000 times
(tote *domain-two* *target-and* 3 *local-constraints*) adds three wires to domain
(choose *domain-two*) chooses two terminals at random
(choose-object *domain-two*) chooses object at random from domain
(choose-terminal '(a b)) chooses terminal from object at random
(use '(start a) '((start)(a b (c))(end)) *target-and* *local-constraints*) => t, uses
funcall to apply each local constraint
(update-domain '(f c) *domain-two*) adds wire (f c) to domain
(in-one-member ...) see below
(update '(b d) '(a b (c)) '(d e (f)) *domain-two*) puts wire in domain btn switches
(member-lis ...) see below
(up '(d b) '(a b (c)) nil) switches wire around before adding it
(in-one-member 'h *domain-two*) finds item in component in domain
(member-lis '(j) '((a)(j)... ) checks whether a list is in list-of-lists
(test-circuit *and-circuit* *target-and*) => t, tests whether circuit fits the target data
(test-setting *or-circuit* (car *target-or*))
(switch-nth '((start b)(b c (d))(c end)(e f (g))) 1) rtns circuit with nth switch switched
(switch (b c (d))) => (b d (c)) throws a switch
(p search ) checks whether co-referential chain of wires occurs, i.e.
current flow, see below
Functions called in *local-constraints*
(tautology data) rtns t if current always flows
(find-switch 'a 'c *domain-two*) => t, rtns t if two terms on same switch
(member-switch 'a 'b '(b a (c))) checks whether two terminals on same switch
Strategies
1. Use strategy that focuses on possible outcomes (complete circuits) one at a time,
or a strategy that focuses on one switch one at a time. So, the procedure checks
what input-output pairs work in the first case, and tries to modify the circuit
appropriately. Or, it gets one switch to work some of the time in the appropriate
way, and then introduces the second switch.
A strategy is a 'global' constraint
1. A circuit must run from start to end via two switches. How could this
constain the generation of moves?
2. A global constraint is one that concerns a circuit as a whole, not an individual
wire.
|#
;;; How do to stats: run 20 cases of search 5000 times, and keep track
;;; of number of solutions, e.g., 50 10 1, 55 22 3, and then do Mann-
;;; Whitney on results.
;;;;;; Part 2: Global constraints on the circuit
;;; Global constraints on the circuit as a whole
;;; A wire must connect to start and not to end, i.e., it must connect to a switch.
;;; A wire must connect to end and not to start, i.e., it must connect to a switch.
;;; Each switch much have wire on single terminal and a wire on at least one of the double terminals.
;;; No indirect circuit from start to end yielding light always on, i.e., no
;;; (start a)(a b)(b c)(c d)(d end). removes all switches, and checks whether current flows, if
;;; target system is not a tautology
(setf *global-constraints* (list
#'(lambda (domain target)(and (> (length (comp-lis '(start) domain)) 1)
(not(in-one-member 'end (comp-lis '(start) domain)))))
#'(lambda (domain target)(and (> (length (comp-lis '(end) domain)) 1)
(not(in-one-member 'start (comp-lis '(end) domain)))))
#'(lambda (domain target)(switches-wired domain))
#'(lambda (domain target)
(or (tautology target)
(not (p-search '((start)) '(end)
(remove-if #'(lambda(item)(= (length item) 3)) domain)))))
))
;;; checks that each switch in circuit is wired, i.e., single terminal and at
;;; least one double terminal are connected to something else
;;; (switches-wired '((start)(a b (c))(d e (f))(g h (i))(end)))
(defun switches-wired(domain)
(let ((switches (find-all-switches domain)))
(swits-wired switches domain)))
;;; rtns t iff each switch is wired into circuit
;;; (swits-wired '((a b (c))(d e (f))) '((start a)(a b (c))(c f)(d e (f))(d end))) => t
(defun swits-wired(switches domain)
(cond((null switches) t)
((switch-wired (car switches) domain)(swits-wired (cdr switches) domain))))
;;; checks that there's a wire attached to a terminal of switch
;;; comp-lis doesn't find '(c) in (... (a b (c) ...) so throw switch
;;; (switch-wired '(a b (c)) '((start)(start a)(a b (c))(c d)(d e (f)))) => t
;;; because switch has single terminal and one of the double terminals
;;; wired to other things
(defun switch-wired(switch domain)
(let ((single-term (car switch))(double-term-1 (cadr switch))
(double-term-2 (caaddr switch)))
(and (> (length (comp-lis (list single-term) domain)) 1)
(or (> (length (comp-lis (list double-term-1) domain)) 1)
(> (length (comp-lis (list double-term-2)(cons (switch switch) domain))) 1)))))
;;; find all switches in circuit, and rtn in a list
;;; (find-all-switches *and-circuit*) => ((b c (d))(e f (g)))
(defun find-all-switches(circuit)
(cond((null circuit) nil)
((= (length (car circuit)) 3)(cons (car circuit)(find-all-switches (cdr circuit))))
(t (find-all-switches (cdr circuit)))))
;;; applies global constraints to complete circuit, rtns t in case all are satisfied
;;; (use-global '((start)(start a)(a b (c))(d e (f))(end d)(end)) nil *global-constraints*) => nil
;;; (use-global '((start)(start a)(a b (c))(c f)(d e (f))(end d)(end)) nil *global-constraints*) => t
;;; (use-global '((start)(start a)(start c)(a b (c))(c f)(d e (f))(end f)(end d)(end)) *target-and* *global-constraints*) => nil, because it wires start to end
;;; (use-global *ore-circuit* *target-ore* *global-constraints*) => t
(defun use-global(domain target constraints)
(cond((null constraints) t)
((funcall (car constraints) domain target)(use-global domain target (cdr constraints)))))
;;;;;; Part 3: Global variables for the program, including target circuits
;;; Correct circuits
;;; circuit for single switch, 'a'
(setf *a-circuit* '((start)(start a)(a b (c))(b end)(end)))
(setf *or-circuit*
'((start)(start a)(a b (c))(b end)(start d)(d e (f))(e end)(end)))
;;; c
;;; start --- a -> b ----- end
;;; | |
;;; | f |
;;; |--------d -> e ------|
(setf *and-circuit*
'((start) (start a)(a b (c))(b d)(d e (f))(e end)(end)))
;;; c f
;;; start --- a ->b---d ->e --- end
;;;;;
(setf *ore-circuit*
'((start)(start a)(a b (c))(b f)(c e)(d e (f))(d end)(end)))
;;; c --- e <- d --- end
;;; start --- a->b --- f
#|
an alternative five wire solution discovered by the program!
|-----------------------|
| |
start ----- c f
b<- a--------d->e
| |
|---------------end
|#
;;; each terminal must be unique
(setf *domain* '((start)(end)(a b)(c d)(e f)(g h) (i j (k)) (l m (n))))
(setf *domain-1* '((start)(end)))
;;; To discover circuit for single switch
(setf *domain-A* '((start)(f g (h))(end))) ;;; one switch and 2 wires
;;; To discover a circuit for two switches
(setf *domain-two* '((start)(a b (c))(d e (f))(end)))
(setf switches '((b c (d)) (f g (h)) ))
(setf wires '((x)(y)(z)))
(setf terminals '((start)(end)))
;;;;; Part 4: High level functions for running the program, including collection of statistics
#|
The following runs were with constraints on the number of moves.
It would be better to have no such constraint, but instead to check
after each move whether the problem is solved.
20 samples of 1000 trials with one constraint Sums
(0 0 3 1 1 0 1 0 4 0 1 0 0 0 0 0 0 1 0 1) 13 and 13/(20 x 1000) = .000065 and successes
(0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 1 1 0 1 0) 5 or successes
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 0 ore successes
20 samples of 1000 trials with only local constraints
(0 2 4 1 1 3 4 5 0 2 2 1 5 3 2 3 0 0 1 2) 41 and successes
(2 4 6 7 3 4 8 3 6 6 6 2 4 4 8 4 6 5 1 6) 95 or successes
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 0 ore successes
20 samples of 1000 trials with only global constraints
(130 160 182 167 181 167 185 168 191 149 165 173 147 173 173 173 167 161 153 151)
3316 and successes
(25 30 29 33 26 44 36 30 30 28 30 30 29 28 22 26 36 40 31 36) 619 or successes
(0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0) 1 ore successes
20 samples of 1000 trials with both local and global constraints
(265 239 229 241 231 263 220 245 255 221 268 261 257 246 238 272 236 224 232 238)
4881 and successes
(69 85 64 60 77 61 70 64 79 67 63 72 64 71 72 61 75 58 60 67) 1359 or successes
(1 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 1 1 0 0) 6 ore successes
Another 20 samples of 1000 trials with both local and global constraints
(216 245 250 228 271 268 259 245 243 276 236 220 227 241 255 211 263 254 237 254) and successes
(67 74 89 66 66 66 57 66 71 68 71 60 70 79 83 83 72 73 75 69) or successes
(0 0 0 0 0 1 0 1 0 0 1 1 0 1 0 0 1 1 0 0) ore successes
|#
;;; keeps statistics on runs using both local and global constraints
(defun keep-stats(number-of-runs)
(prog((and-lis nil)(or-lis nil)(ore-lis nil)(count 0))
loop
(cond((>= count number-of-runs)
(princ and-lis)(princ " and successes")(terpri)
(princ or-lis) (princ " or successes")(terpri)
(princ ore-lis)(princ " ore successes")(terpri)
(return t))
(t (setf and-lis (cons (length
(test-tote *domain-two* *target-and* 3 1000 *local-constraints* *global-constraints*)) and-lis))
(setf or-lis (cons (length
(test-tote *domain-two* *target-or* 4 1000 *local-constraints* *global-constraints*)) or-lis))
(setf ore-lis (cons (length
(test-tote *domain-two* *target-ore* 4 1000 *local-constraints* *global-constraints*)) ore-lis))
(setf count (+ 1 count))(go loop)))))
;;; keeps stats but using oldtest-tote and only local constraints
(defun local-keep-stats(number-of-runs)
(prog((and-lis nil)(or-lis nil)(ore-lis nil)(count 0))
loop
(cond((>= count number-of-runs)
(princ (length and-lis))(princ " and successes")(terpri)
(princ (length or-lis)) (princ " or successes")(terpri)
(princ (length ore-lis))(princ " ore successes")(terpri)
(return t))
(t (setf and-lis (append
(oldtest-tote *domain-two* *target-and* 4 5000 *local-constraints*) and-lis))
(setf or-lis (append
(oldtest-tote *domain-two* *target-or* 4 5000 *local-constraints*) or-lis))
(setf ore-lis (append
(oldtest-tote *domain-two* *target-ore* 4 5000 *local-constraints*) ore-lis))
(setf count (+ 1 count))(go loop)))))
;;; Higher level function
;;; repeatedly test tote ab initio
;;; domain is the starting set of components
;;; target is the required performance
;;; no-of-wires is the (minimum) number of wires to be added to solve
;;; the problem
;;; max-iteration is the maximum number of iterations of tote
;;; to be used to try to solve the problem
;;; constraints, if nil, uses no constraints; otherwise, it can be set, e.g., to
;;; *local-constraints*
;;; (test-tote *domain-A* *target-a* 2 100 nil nil)
;;; (test-tote *domain-A* *target-a* 2 100 *local-constraints* nil)
;;; (test-tote *domain-two* *target-and* 3 5000 nil nil)
;;; (test-tote *domain-two* *target-and* 3 100 *local-constraints* *global-constraints*) =>
;;; 1 ((START) (START A) (A B (C)) (B E) (D E (F)) (D END) (END))
;;; (test-tote *domain-two* *target-or* 4 100 *local-constraints* *global-constraints*) =>
;;; 7 ((START) (START D) (D B) (A B (C)) (A END) (END E) (D E (F)) (END))
;;; (test-tote *domain-two* *target-ore* 4 5000 *local-constraints* *global-constraints*)
;;; 1436 ((START) (START D) (A B (C)) (C E) (A END) (B F) (D E (F)) (END))
;;; (test-tote *domain-two* *target-ore* 4 10000 *local-constraints* nil) =>
;;; 3128 ((START) (START D)(A B (C))(C E)(B F)(A END)(D E (F))(END))
;;; (test-tote *domain-two* *target-ore* 5 10000 *local-constraints* nil)
;;; 2454 ((START)(START C)(START F)(A B (C))(B END)(A D)(D E (F))(E END)(END))
;;; and (((START) (START C) (START F) (A B (C)) (B E) (B END) (A D) (D E (F)) (END)))
;;; very clever, only one wire between the two switches!
(defun test-tote(domain target no-of-wires max-iteration local-constraints global-constraints)
(prog((iteration 1)(circuit nil)(output nil))
loop
(cond((setf circuit (tote domain target no-of-wires local-constraints))
(cond((use-global circuit target global-constraints)
; (princ iteration)(princ " ")(princ circuit)(terpri)
(cond((test-circuit circuit target)
; (princ "success ")(princ iteration)(princ " ")(terpri)
(setf output (cons circuit output))
(setf iteration (+ iteration 1))(go loop))
((>= iteration max-iteration)(terpri)
(princ "output contains ")(princ (length output))
(princ " successes")(terpri)(return output))
(t (setf iteration (+ iteration 1))(go loop))))
(t (go loop))))
(t (princ "No output was possible. Error")(terpri)(return nil)))))
;;; tote unit, no-of-wires = max number of wires to be added
;;; (tote *domain-A* nil 2 nil)
;;; (tote *domain-A* *target-a* 2 *local-constraints* *global-constraints*) =>
;;; ((START) (START F) (F G (H)) ((H) END) (END))
;;; (tote *domain-two* nil 3 nil)
;;; (loop for i from 1 to 100 do (print (tote *domain-A* *target-a* 2 *local-constraints*)))
;;; (tote *and-circuit* *target-and* 4 *local-constraints*)
;;; (tote *domain-two* *target-ore* 4 *local-constraints*)
;;; adds wires at random up to no-of-wires, but use checks constraints, and
;;; rtns updated domain, whether successful or not
;;; In this more recent version, I've built in the idea of test-circuit after each
;;; wire is added, but now it never solves any problems.
;;; *domain-two* contains start, end, and two switches
;;; Tote adds given no-of-wires to it and use checks *local-constraints*
;;; before updating them
;;; (tote *domain-two* *target-and* 3 *local-constraints*) =>
;;; ((START) (START B) (START F) (F END) (A B (C)) (D E (F)) (END))
(defun tote(domain target no-of-wires constraints)
(prog((wire nil)(count 0))
loop
(cond((= count no-of-wires)(return domain))
((and (setf wire (choose domain))(use wire domain target constraints))
; (setf domain (cons wire domain))
(setf domain (update-domain wire domain)) ; need a more elegant fn than cons
(setf count (+ count 1))
(go loop))
(t (go loop)))))
;;; updates domain by adding wire in a sensible place, calls update to do the work
;;; (update-domain '(a d) *domain-two*) => ((START) (A B (C)) (A D) (D E (F)) (END))
;;; (update-domain '(d a) *domain-two*) => ((START) (A B (C)) (A D) (D E (F)) (END))
;;; (update-domain '(f c) *domain-two*) => ((START) (A B (C)) (C F) (D E (F)) (END))
;;; (update-domain '(c c) *domain-two*) => ((START) (A B (C)) (C C) (D E (F)) (END))
(defun update-domain(wire domain)
(let ((hd (in-one-member (car wire) domain))
(tl (in-one-member (cadr wire) domain)))
(update wire hd tl domain)))
;;; switches round wire or order of switches in domain in order
;;; to insert new wire
;;; *domain-two* is ((START) (A B (C)) (D E (F)) (END))
;;; (update '(b b) '(a b (c)) '(a b (c)) *domain-two*) =>
;;; ((START) (A B (C)) (B B) (D E (F)) (END))
;;; (update '(b d) '(a b (c)) '(d e (f)) *domain-two*) =>
;;; ((START) (A B (C)) (B D) (D E (F)) (END))
;;; (update '(d b) '(a b (c)) '(d e (f)) *domain-two*) => switch wire around to insert it =>
;;; ((START) (A B (C)) (B D) (D E (F)) (END))
;;; (update '(d b) '(d e (f)) '(a b (c)) *domain-two*) =>
;;; ((START) (A B (C)) (B D) (D E (F)) (END))
(defun update(wire hd tl domain)
(cond ((null domain) nil)
((and (equal hd tl)(equal hd (car domain))) ; where wire is from terminal to itself, or on same switch
(up wire hd (cdr domain)))
((and (equal hd (car domain))(member-lis tl (cdr domain)))
; (print 'one)
(up wire hd (cdr domain)))
((and (equal tl (car domain))(member-lis hd (cdr domain)))
; (print 'two)
(up wire tl (cdr domain)))
(t (cons (car domain)(update wire hd tl (cdr domain))))))
;;; switches round wire, if nec, before inserting it into tail of domain
;;; If graphics used as output then no need for this fn
;;; (up '(b d) '(a b (c)) nil) => ((a b (c))(b d))
;;; (up '(d b) '(a b (c)) nil) => ((a b (c))(b d))
(defun up(wire component tail-domain)
(cond((in-one-member (car wire)(list component))
(cons component (cons wire tail-domain)))
(t (cons component (cons (reverse wire) tail-domain)))))
;;; finds item in list in domain, even 'c in switch such as (a b (c)),
;;; and rtns complete component
;;; (in-one-member 'start *domain*) => (start)
;;; (in-one-member 'd *domain*) => (c d)
;;; (in-one-member 'k *domain*) => (i j (k))
(defun in-one-member(item domain)
(cond((null domain) nil)
((or (member item (car domain))(member-lis (list item)(car domain)))
(car domain))
(t (in-one-member item (cdr domain)))))
;;;;;; Part 5: Local constraints on wiring circuits
#|
*local-constraints* include those that individuals are likely
to bring to the experiment. Could they learn them? If so,
how? The idea would be to compute a constraint and
add it to the list of constaints in *local-constraints*
Need to think about how they could be
acquired from a mental model of a circuit.
|#
;;; OK a list of local constraints, which are each stated as lambda functions,
;;; a new wire is rejected if it fails at least one of them, i.e.,
;;; it returns a nil
;;; The local constraints are
;;; 1 wire isn't from item to itself
;;; 2 wire isn't already in domain
;;; 3 converse of wire isn't already in domain
;;; 4 Don't wire one terminal on a switch to another terminal on a switch -- that's what
;;; the switch itself does.
;;; 5 If the target isn't a tautology, then do not have a wire '(start end)
;;; Fns in the local constraints return t when the circuit is OK, and nil when the current
;;; wiring is to be rejected. So, final tautology should rtn t in case the circuit is a
;;; tautology, or the wire isn't from 'start to 'end
(setf *local-constraints*
(list
#'(lambda (wire domain target)(not (equal (car wire)(cadr wire)))) ; 1
#'(lambda (wire domain target)(not (member-lis wire domain))) ; 2
#'(lambda (wire domain target)(not (member-lis (reverse wire) domain))) ; 3
#'(lambda (wire domain target)(not (find-switch (car wire)(cadr wire) domain))) ; 4
#'(lambda (wire domain target) ; 5
(or (tautology target)
(not (and (member 'start wire)(member 'end wire)))))
))
;;; OK tests whether wire, which is a new wiring, meets all local constraints.
;;; So the list of constraints is formulated so that if failure occurs in at least
;;; one of them it returns nil, i.e. use rtns nil instead of making a recursion
;;; (use '(start a) '((start)(a b (c))(end)) *target-A* *local-constraints*) => t
;;; (use '(end start) '((start)(a b (c))(end)) *target-A* *local-constraints*) => nil
;;; (use '(a a) '((b c)(d e)) *target-and* *local-constraints*) => nil, because 1 item wired to itself
;;; (use '(a b) '((b c)(a b)(d e)) *target-and* *local-constraints*) => nil, because 2 item already in domain
;;; (use '(a b) '((c d)(b a)(e f)) *target-and* *local-constraints*) => nil, because 3 converse wire in domain
;;; (use '(b c) '((start)(a b (c))(end)) *target-A* *local-constraints*) => nil, because 4 terminals on same switch
;;; (use '(start end) '((start)(a b (c))(end)) *target-and* *local-constraints*) => nil, because 5
;;; *target-and* is not tautology
;;; (use '(b c) '((a b)(c d)(e f)) *target-and* *local-constraints*) => t, because it passes all constraints
;;; (use '(a b) '((c d)(b a)(e f)) *target-and* nil) => t, because nil.constraints
(defun use(wire domain target constraints)
(cond((null constraints) t)
((funcall (car constraints) wire domain target)(use wire domain target (cdr constraints)))))
;;; OK if data are tautology returns t
;;; keeps recursing as long as datum is 1
;;; (tautology *target-A*) => nil
;;; (tautology *target-and*) => nil
;;; (tautology *target-or*) => nil
;;; (tautology '(((1 1) 1) ((1 0) 1) ((0 1) 1) ((0 0) 1))) => t
(defun tautology(data)
(cond((null data) t)
((equal 1 (car(reverse(car data))))(tautology (cdr data)))))
;;; OK finds a switch, if any, containing both terminals
;;; *domain-two* = '((start)(a b (c))(d e (f))(end))
;;; (find-switch 'a 'c *domain-two*) => t
;;; (find-switch 'a 'd *domain-two*) => nil
;;; (find-switch 'f 'd *domain-two*) => t
(defun find-switch(terminal-1 terminal-2 domain)
(cond((null domain) nil)
((member-switch terminal-1 terminal-2 (car domain)) t)
(t (find-switch terminal-1 terminal-2 (cdr domain)))))
;;; OK if two terminals are in same component rtns component or t
;;; (member-switch 'a 'b '(b a (c))) => (b a (c))
;;; (member-switch 'b 'a '(c b (a))) => t
(defun member-switch(terminal-1 terminal-2 component)
(and (or (member terminal-1 component)(member-lis (list terminal-1) component))
(or (member terminal-2 component)(member-lis (list terminal-2) component))))
;;; OK checks whether a list is in a list-of-lists
;;; (member-lis '(a b) '(c (a b) d)) => t
;;; (member-lis '(a b) '(c (b a) d)) => nil
(defun member-lis(lis lis-of-lis)
(cond((null lis-of-lis) nil)
((equal lis (car lis-of-lis)) t)
(t (member-lis lis (cdr lis-of-lis)))))
;;; OK chooses, in principle after meeting constraints by removing items from
;;; domain prior to choosing
;;; where e.g. (random 2) => 0 or 1
;;; *domain* is ((START) (END) (A B) (C D) (E F) (G H) (I J (K)) (L M (N)))
;;; (choose *domain*) => (F C), i.e., it wires C to F
;;; (p-search '((L)) '(end) '((L M (N))(M END)(END))) => ((L M (N))(M END))
;;; (choose *domain-A*) => ((G START))
;;; (choose *domain-two*) => (A (F))
(defun choose (entities)
(let* ((obj-1 (choose-object entities))(obj-2 (choose-object entities))
(terminal-1 (choose-terminal obj-1))(terminal-2 (choose-terminal obj-2)))
(cond((listp terminal-1)(setf terminal-1 (car terminal-1))))
(cond((listp terminal-2)(setf terminal-2 (car terminal-2))))
(list terminal-1 terminal-2)))
;;; OK chooses object at random from domain
;;; (choose-object *domain*)
(defun choose-object(entities)
(elt entities (random (length entities))))
;;; OK chooses terminal from object
;;; nb list-structure for switches
;;; (choose-terminal '(start)) => start
;;; (choose-terminal '(a b)) => a, b
;;; (choose-terminal '(f g (h))) => f, or g or (h)
(defun choose-terminal(obj)
(elt obj (random (length obj))))
;;;;; Part 6: Target Boolean concepts (to reverse engineer)
;;; Global variable for inputs-outputs for circuits
;;; for 'and', 'or', 'or else'
(setf *target-a* '(
((1) 1)
((0) 0)))
(setf *target-and* '(
((1 1) 1)
((1 0) 0)
((0 1) 0)
((0 0) 0)))
(setf *target-or* '(
((1 1) 1)
((1 0) 1)
((0 1) 1)
((0 0) 0)))
(setf *target-ore* '(
((1 1) 0)
((1 0) 1)
((0 1) 1)
((0 0) 0)))
;;;;;; Part 7: Tests for current flow through circuit depending on switch positions
#|
(test-flow *ore-circuit*) rtns list of switch configurations in which current flows
(count-switches circuit) rtns no of switches in circuit
(gen-patterns 2) rtns all possible switch settings, e.g., ((1 1)(0 1)(1 0)(0 0))
(test-fl '((1 1)(0 1)(1 0)(0 0)) *and-circuit*) rtns configs in which flows
(set-switches '(0 1) '((START)(START A)(A B (C))(B D)(D E (F))(END)) 1)
sets the switches to the configuration in first parameter
(switch-nth circuit count) switches nth = count switch (see below)
(p-search '((start)) '(end) circuit) looks for co-ref chain, i.e., current flows
|#
;;; tests whether current flows in at least one switch configuration of circuit
;;; (test-flow '((START)(START A)(A B (C))(B D)(D E (F))(G H (I))(END)))
;;; (test-flow *and-circuit*) => ((1 1)) (test-flow *ore-circuit*) => ((0 1)(1 0))
(defun test-flow(circuit)
(let ((configurations (gen-patterns (count-switches circuit))))
(test-fl configurations circuit)))
;;; given list of switch configurations, tests each of them for current flow, and rtns
;;; list of those configurations for which it does
;;; (test-fl '((1 1)(1 0)(0 1)(0 0)) *ore-circuit*)
(defun test-fl(configurations circuit)
(cond((null configurations) nil)
((p-search '((start)) '(end)(set-switches (car configurations) circuit 1))
(cons (car configurations)(test-fl (cdr configurations) circuit)))
(t (test-fl (cdr configurations) circuit))))
;;; Tests in which switch configurations current flows
;;; p-search circuit and store output, switch nxt switch and
;;; p-search again
;;; 1 1 1
;;; 1 1 0
;;; 1 0 1
;;; 1 0 0
;;; (switch-nth circuit 1)
;;; Generates the n^2 patterns of binaries given n
;;; (gen-patterns 3) =>
;;; ((1 1 1) (0 1 1) (1 0 1) (0 0 1) (1 1 0) (0 1 0) (1 0 0) (0 0 0))
(defun gen-patterns(n)
(cond((= n 1)(list '(1) '(0)))
(t (mapcan #'(lambda(lis)(cons (cons '1 lis)(list (cons '0 lis))))(gen-patterns (- n 1))))))
;;; takes a configuration of switches '(1 0 0) and switches those switches in circuit shown as 0
;;; (SET-SWITCHES '(0 0 0)'((START)(START A)(A B (C))(B D)(D E (F))(G H (I))(END)) 1)
;;; => ((START) (START A) (A B (C)) (B D) (D F (E)) (G I (H)) (END))
;;; (SET-SWITCHES '(0 1)'((START)(START A)(A B (C))(B D)(D E (F))(END)) 1) =>
;;; ((START)(START A) (A C (B)) (B D) (D E (F)) (END))
;;; count is a parameter set to 1 on call, it counts the number of switches, on each recursive call
(defun set-switches(lis circuit count)
(cond((null lis) circuit)
((= (car lis) 1)(set-switches (cdr lis) circuit (+ 1 count)))
(t (set-switches (cdr lis)(switch-nth circuit count) (+ 1 count)))))
;;; counts the number of switches in a circuit
;;; (count-switches '((start)(start a)(g h (i))(a b (c))(b f)(c e)(d e (f))(d end)(end))) => 3
(defun count-switches(circuit)
(cond ((null circuit) 0)
((= (length (car circuit)) 3)(+ 1 (count-switches (cdr circuit))))
(t (count-switches (cdr circuit)))))
#|
test-circuit -- tests whether circuit yields correct input-output pairs (*target*)
test-setting -- tests single input-output pair
switch-nth -- throws nth switch in circuit
switch -- fn that throws switch
p-search - checks whether current flows, see Part N
|#
;;; Before running, comment out print instruction in
;;; p-search
;;; (test-circuit *and-circuit* *target-and*) => t
;;; (test-circuit *or-circuit* *target-or*) => t
;;; (test-circuit *ore-circuit* *target-ore*) => t
;;; (test-circuit *a-circuit* *target-a*) => t
;;; (test-circuit *and-circuit* *target-or*) => nil
;;; (test-circuit '((start)(start a)(a b (c))(b f)(c e)(d e (f))(d end)(end)) *target-ore*) => t
;;; exits either when test-setting rtns nil (because circuit fails), or when
;;; it works every time
(defun test-circuit(circuit data)
(cond((null data) t)
((test-setting circuit (car data))(test-circuit circuit (cdr data)))))
;;; takes an datum (input and target, e.g. ((1 0) 1),
;;; and tests whether circuit given input yields target
;;; It can cope with circuits containing 1, 2, or 3 switches
;;; Sets switches according to input, i.e., (0 0) calls for
;;; both switches in circuit to be switched in position.
;;; Calls p-search to see whether current flows thru
;;; circuit. If null.circuit rtn sets response to 0, but if
;;; current does flow and a circuit is returned, sets
;;; response to 1. If response = target prints so,
;;; otherwise prints that circuit was incorrect.
;;; Finally rtns circuit, which is either null or an actual
;;; circuit, regardless of whether it is right or wrong
;;;
;;; (test-setting *or-circuit* (car *target-or*)) (test-setting *a-circuit* (car *target-a*))
(defun test-setting(circuit datum)
(let ((input (car datum))(target (cadr datum))(response nil))
(cond((= (car input) 0)
(setf circuit (switch-nth circuit 1)))) ; for first input, sets 1st switch
(cond((and (> (length input) 1)(= (cadr input) 0))
(setf circuit (switch-nth circuit 2)))) ; if second input, sets 2nd switch
(cond((and (> (length input) 2)(= (caddr input) 0))
(setf circuit (switch-nth circuit 3)))) ; if third input, sets 3rd switch
(setf circuit (p-search '((start)) '(end) circuit))
(cond((null circuit)(setf response 0))
(t (setf response 1)))
; (terpri)(princ "Setting for input of ")
; (princ input)(terpri)
(cond((= response target)
; (princ " yields correct target of ")(princ target)(terpri)
t)
(t ; (princ " yields incorrect target of ")(princ target)(terpri)
nil))))
;;; takes a circuit and rtns it with the nth switch switched
;;; (switch-nth '((start b)(b c (d))(c end)(e f (g))) 1) =>
;;; ((START B) (B D (C)) (C END) (E F (G)))
;;; (switch-nth '((START B) (B D (C)) (C END) (E F (G))(f end)(h i (j))) 3)
(defun switch-nth(circuit nth)
(let ((swi nil))
(cond((null circuit) nil)
((setf swi (switch (car circuit)))
(cond((= nth 1)(cons swi (cdr circuit))) ; no further recursion
(t (cons (car circuit)(switch-nth (cdr circuit)(- nth 1))))))
(t (cons (car circuit)(switch-nth (cdr circuit) nth))))))
;;; A function for 'throwing' a switch
;;; (setf switch1 '(b c (d)))
;;; (switch switch1) => (b d (c))
;;; (switch '(a b)) => nil, i.e., the parameter isn't a switch
(defun switch(swi)
(cond((and (atom (car swi))(atom (cadr swi))(listp(car(last swi))))
(list (car swi)(caar(last swi))(list(cadr swi))))))
#|
We use p-search to test whether current flows
(p-search '((start)) '(end) *or-circuit*) =>
((START B) (B C (D)) (C END)) - finds first route
(p-search '((start)) '(end) *ore-circuit*) => NIL Why?
Because current doesn't flow in its current setting!
The code is based directly on functions that I wrote in
another program, and that search for a chain of co-referential
premises. I've changed the names of some variables to
make the present functions more perspicuous as a way of
checking whether current flows in a circuit. The basic idea
is that current flows within items at the basic level of a list,
such as (a b), and also from one entity in such a list to the
same type of entity in another list, e.g.,
(p-search '((a)) '(d) '((a b)(b c)(c d))) => ((A B) (B C) (C D))
| | |
start end components of circuit; can
but is a be listed in any order
double
list in order to
grow paths
p-search: top-level function
p-update: updates path
other-ref-than
(comp-lis '(B) '((X B) (A B) (B C) (C D) (E D) (F D))) => ((X B) (A B) (B C))
member
longest
rec-comps (converts path into comps)
find-one
joint-occurs
member
p-search: The high-level function for searching for
co-referential paths
breadth-first search for path(s) leading from initial
member of path e.g.
(p-search '((a)) '(d) '((a b)(b c)(c d))) => '((A B) (B C) (C D))
list of relevant components in 'co-referential' order
using update to find the relevant components to continue
path choses longest path because all components that do
not contain extraneous elements are relevant to the
circuit; and then rtns list of relevant components
rec-comps recovers premises corresponding to (longest)
path
|#
;;; if null.paths then rec-comps rtns the components
;;; from longest path
;;; else if last item in car.paths = goal then recurse
;;; adding car.paths to output and searching on
;;; for cdr.paths (because can be several paths!)
;;; elseif p-update adds to car.paths (it rtns nil if it
;;; doesn't) then recurse putting extended path
;;; in place of car.paths
;;; else recurse abandoning car.paths (because it
;;; leads nowhere)
(defun p-search(paths goal comps &optional output)
(let ((new-paths nil))
; (print paths)
(cond((null paths)(rec-comps (longest output) comps))
((equal (last (car paths)) goal)
(p-search (cdr paths) goal comps (cons (car paths) output)))
((setf new-paths (p-update (car paths) comps))
(p-search (append new-paths (cdr paths)) goal comps output))
(t (p-search (cdr paths) goal comps output)))))
;;; rtns the LAST one from those of maximum length.
;;; (longest '((A X) (A Y X) (A B C D)(A B C E) (A Z X)))
;;; => (A B C E), i.e., rtns last of longest in paths.
;;; If only one path left rtns it (bottom out case)
;;; elseif car.paths longer than cadr.paths get rid
;;; of cadr.paths in recursion
;;; else tail recursion, getting rid of car.paths
(defun longest (paths)
(cond((<= (length paths) 1) (car paths))
((> (length (car paths))(length (cadr paths)))
(longest (cons (car paths)(cddr paths))))
(t (longest (cdr paths)))))
#|
p-update updates a path into new paths using the components, e.g.
Current
path Components New paths
| | I
(p-update '(a b) '((x b)(c d)(c b(d)))) => ((A B X) (A B C))
So, it adds any component containing b, which is at the end of
the current path.
(p-update '(a b) '((x b)(a b)(e g)(b c)))
=> ((X B)(B C)) => (X C) => ((A B X)(A B C))
(p-update '(a c b) '((x b)(a b)(e g)(b c)))
=> ((X B)) => (X) => ((A C B X))
|#
(defun p-update(path comps)
(let ((outlis (comp-lis (last path) comps))) ; last rtns list of last item
(mapcar #'(lambda(item)(append path (list item)))
(mapcar #'(lambda(component)(car (other-ref-than (last path) component)))
(remove-if #'(lambda(comp)(member (car (other-ref-than (last path) comp)) path))
outlis)))))
;;; takes path and uses it to rtn corresponding components, e.g.
;;; (rec-comps '(A B C D) '((X B) (A B) (B C) (C D) (E D) (F D)))
;;; => ((A B) (B C) (C D))
(defun rec-comps(path comps)
(cond((null (cdr path)) nil)
(t (cons (find-one (list(car path))(list (cadr path)) comps)
(rec-comps (cdr path) comps)))))
;;; rtns ref from prem other than term, and nil if term
;;; doesn't occur in prem. Here a trivial fn, but it could
;;; call parse of premises retrieve NPs, and then retrieve
;;; another one
;;; (other-ref-than '(B) '(D B)) => (D)
(defun other-ref-than(term prem)
(let ((subj (car prem))(obj (cadr prem)))
(cond((equal (car term) subj)(list obj))
((equal (car term) obj)(list subj)))))
;;; rtns first component in comps, if any, that contains
;;; both e1 and e2, which are both lists e.g.
;;; (find-one '(E) '(D) '((A B) (B C) (C D) (E D F)))
;;; => '(E D F)
(defun find-one(e1 e2 comps)
(cond((null comps) nil)
((joint-occurs (car e1)(car e2) (car comps))
(car comps)) ; take car to rid lists
(t (find-one e1 e2 (cdr comps)))))
;;; rtns list of itm2 iff itm1 and itm2 are both
;;; in comp
;;; (joint-occurs 'a 'b '(a b)) => (b)
(defun joint-occurs(itm1 itm2 prem)
(and (member itm1 prem)(member itm2 prem)))
;;; makes list of all components containing item such as '(b)
;;; Example:
;;; (comp-lis '(B) '((X B) (A B) (B C) (C D) (E D) (F D)))
;;; => ((X B) (A B) (B C))
(defun comp-lis(term comps)
(cond((null comps) nil)
((member (car term) (car comps))
(cons (car comps)(comp-lis term (cdr comps))))
(t (comp-lis term (cdr comps)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END OF FILE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;