Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP Path: utzoo!mnetor!seismo!rutgers!sri-unix!hplabs!decwrl!sun!imagen!turner From: turner@imagen.UUCP (D'arc Angel) Newsgroups: comp.ai Subject: AI expert sources (part 9 of 9) whew !!! Message-ID: <802@imagen.UUCP> Date: Sun, 18-Jan-87 22:52:13 EST Article-I.D.: imagen.802 Posted: Sun Jan 18 22:52:13 1987 Date-Received: Mon, 19-Jan-87 23:35:56 EST Organization: The Houses of the Holy Lines: 981 Keywords: ai,sources X ((eq a 'arith) (check-compute x)) X ((eq a 'substr) (check-substr x)) X ((eq a 'accept) (check-accept x)) X ((eq a 'acceptline) (check-acceptline x)) X ((eq a 'crlf) (check-crlf x)) X ((eq a 'genatom) (check-genatom x)) X ((eq a 'litval) (check-litval x)) X ((eq a 'tabto) (check-tabto x)) X ((eq a 'rjust) (check-rjust x)) X ((not (externalp a)) X (%warn '"rhs function not declared external" a))))) X X(defun check-litval (x) X (or (= (length x) 2) (%warn '|wrong number of arguments| x)) X (check-rhs-atomic (cadr x))) X X(defun check-accept (x) X (cond ((= (length x) 1) nil) X ((= (length x) 2) (check-rhs-atomic (cadr x))) X (t (%warn '|too many arguments| x)))) X X(defun check-acceptline (x) X (mapc (function check-rhs-atomic) (cdr x))) X X(defun check-crlf (x) X (check-0-args x)) X X(defun check-genatom (x) (check-0-args x)) X X(defun check-tabto (x) X (or (= (length x) 2) (%warn '|wrong number of arguments| x)) X (check-print-control (cadr x))) X X(defun check-rjust (x) X (or (= (length x) 2) (%warn '|wrong number of arguments| x)) X (check-print-control (cadr x))) X X(defun check-0-args (x) X (or (= (length x) 1.) (%warn '|should not have arguments| x))) X X(defun check-substr (x) X (or (= (length x) 4.) (%warn '|wrong number of arguments| x)) X (check-rhs-ce-var (cadr x)) X (check-substr-index (caddr x)) X (check-last-substr-index (cadddr x))) X X(defun check-compute (x) (check-arithmetic (cdr x))) X X(defun check-arithmetic (l) X (cond ((atom l) X (%warn '|syntax error in arithmetic expression| l)) X ((atom (cdr l)) (check-term (car l))) X ((not (memq (cadr l) '(+ - * // \\))) X (%warn '|unknown operator| l)) X (t (check-term (car l)) (check-arithmetic (cddr l))))) X X(defun check-term (x) X (cond ((listp x) (check-arithmetic x)) X (t (check-rhs-atomic x)))) X X(defun check-last-substr-index (x) X (or (eq x 'inf) (check-substr-index x))) X X(defun check-substr-index (x) X (prog (v) X (cond ((bound? x) (return x))) X (setq v ($litbind x)) X (cond ((not (numberp v)) X (%warn '|unbound symbol used as index in substr| x)) X ((or (< v 1.) (> v 127.)) X (%warn '|index out of bounds in tab| x))))) X X(defun check-print-control (x) X (prog () X (cond ((bound? x) (return x))) X (cond ((or (not (numberp x)) (< x 1.) (> x 127.)) X (%warn '|illegal value for printer control| x))))) X X(defun check-tab-index (x) X (prog (v) X (cond ((bound? x) (return x))) X (setq v ($litbind x)) X (cond ((not (numberp v)) X (%warn '|unbound symbol occurs after ^| x)) X ((or (< v 1.) (> v 127.)) X (%warn '|index out of bounds after ^| x))))) X X(defun note-variable (var) X (setq *rhs-bound-vars* (cons var *rhs-bound-vars*))) X X(defun bound? (var) X (or (memq var *rhs-bound-vars*) X (var-dope var))) X X(defun note-ce-variable (ce-var) X (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*))) X X(defun ce-bound? (ce-var) X (or (memq ce-var *rhs-bound-ce-vars*) X (ce-var-dope ce-var))) X X;;; Top level routines X X(defun process-changes (adds dels) X (prog (x) X process-deletes (and (atom dels) (go process-adds)) X (setq x (car dels)) X (setq dels (cdr dels)) X (remove-from-wm x) X (go process-deletes) X process-adds (and (atom adds) (return nil)) X (setq x (car adds)) X (setq adds (cdr adds)) X (add-to-wm x nil) X (go process-adds))) X X(defun main nil X (prog (instance r) X (setq *halt-flag* nil) X (setq *break-flag* nil) X (setq instance nil) X dil (setq *phase* 'conflict-resolution) X (cond (*halt-flag* X (setq r '|end -- explicit halt|) X (go finis)) X ((zerop *remaining-cycles*) X (setq r '***break***) X (setq *break-flag* t) X (go finis)) X (*break-flag* (setq r '***break***) (go finis))) X (setq *remaining-cycles* (1- *remaining-cycles*)) X (setq instance (conflict-resolution)) X (cond ((not instance) X (setq r '|end -- no production true|) X (go finis))) X (setq *phase* (car instance)) X (accum-stats) X (eval-rhs (car instance) (cdr instance)) X (check-limits) X (and (broken (car instance)) (setq *break-flag* t)) X (go dil) X finis (setq *p-name* nil) X (return r))) X X(defun do-continue (wmi) X (cond (*critical* X (terpri) X (princ '|warning: network may be inconsistent|))) X (process-changes wmi nil) X (print-times (main))) X X(defun accum-stats nil X (setq *cycle-count* (1+ *cycle-count*)) X (setq *total-token* (+ *total-token* *current-token*)) X (cond ((> *current-token* *max-token*) X (setq *max-token* *current-token*))) X (setq *total-wm* (+ *total-wm* *current-wm*)) X (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*)))) X X X(defun print-times (mess) X (prog (cc ac) X (cond (*break-flag* (terpri) (return mess))) X (setq cc (plus (float *cycle-count*) 1.0e-20)) X (setq ac (plus (float *action-count*) 1.0e-20)) X (terpri) X (princ mess) X (pm-size) X (printlinec (list *cycle-count* X 'firings X (list *action-count* 'rhs 'actions))) X (terpri) X (printlinec (list (round (quotient (float *total-wm*) cc)) X 'mean 'working 'memory 'size X (list *max-wm* 'maximum))) X (terpri) X (printlinec (list (round (quotient (float *total-cs*) cc)) X 'mean 'conflict 'set 'size X (list *max-cs* 'maximum))) X (terpri) X (printlinec (list (round (quotient (float *total-token*) cc)) X 'mean 'token 'memory 'size X (list *max-token* 'maximum))) X (terpri))) X X(defun pm-size nil X (terpri) X (printlinec (list *pcount* X 'productions X (list *real-cnt* '// *virtual-cnt* 'nodes))) X (terpri)) X X(defun check-limits nil X (cond ((> (length *conflict-set*) *limit-cs*) X (terpri) X (terpri) X (printlinec (list '|conflict set size exceeded the limit of| X *limit-cs* X '|after| X *p-name*)) X (setq *halt-flag* t))) X (cond ((> *current-token* *limit-token*) X (terpri) X (terpri) X (printlinec (list '|token memory size exceeded the limit of| X *limit-token* X '|after| X *p-name*)) X (setq *halt-flag* t)))) X X X(defun top-level-remove (z) X (cond ((equal z '(*)) (process-changes nil (get-wm nil))) X (t (process-changes nil (get-wm z))))) X X(defun excise ("e &rest z) (mapc (function excise-p) z)) X X(defun run ("e &rest z) X (cond ((null z) (setq *remaining-cycles* 1000000.) (do-continue nil)) X ((and (atom (cdr z)) (numberp (car z)) (> (car z) 0.)) X (setq *remaining-cycles* (car z)) X (do-continue nil)) X (t 'what\?))) X X(defmacro strategy (&rest z) X `(cond ((atom ',z) *strategy*) X ((equal ',z '(lex)) (setq *strategy* 'lex)) X ((equal ',z '(mea)) (setq *strategy* 'mea)) X (t 'what\?))) X X(defmacro cs (&optional z) X `(cond ((null ',z) (conflict-set)) X (t 'what?))) X X(defmacro watch (&rest z) X `(cond ((equal ',z '(0.)) X (setq *wtrace* nil) X (setq *ptrace* nil) X 0.) X ((equal ',z '(1.)) (setq *wtrace* nil) (setq *ptrace* t) 1.) X ((equal ',z '(2.)) (setq *wtrace* t) (setq *ptrace* t) 2.) X ((equal ',z '(3.)) X (setq *wtrace* t) X (setq *ptrace* t) X '(2. -- conflict set trace not supported)) X ((and (atom ',z) (null *ptrace*)) 0.) X ((and (atom ',z) (null *wtrace*)) 1.) X ((atom ',z) 2.) X (t 'what\?))) X X(defun external ("e &rest z) (catch (external2 z) '!error!)) X X(defun external2 (z) (mapc (function external3) z)) X X(defun external3 (x) X (cond ((symbolp x) (putprop x t 'external-routine) X (setq *externals* (enter x *externals*))) X (t (%error '|not a legal function name| x)))) X X(defun externalp (x) X (cond ((symbolp x) (get x 'external-routine)) X (t (%warn '|not a legal function name| x) nil))) X X(defmacro pbreak (&rest z) X `(cond ((atom ',z) (terpri) *brkpts*) X (t (mapc (function pbreak2) ',z) nil))) X X(defun pbreak2 (rule) X (cond ((not (symbolp rule)) (%warn '|illegal name| rule)) X ((not (get rule 'topnode)) (%warn '|not a production| rule)) X ((memq rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*))) X (t (setq *brkpts* (cons rule *brkpts*))))) X X(defun rematm (atm list) X (cond ((atom list) list) X ((eq atm (car list)) (rematm atm (cdr list))) X (t (cons (car list) (rematm atm (cdr list)))))) X X(defun broken (rule) (memq rule *brkpts*)) X X XPRTOWER.OPS X X(i-g-v) X; ************************************************************** X; TOWERS OF HANOI problem for 3 disks including printing of towers X; Version 2 X; This program was translated from a version written by Jeff Shrager and X; Adele Howe in the production system language PRISM. X X; The algorithm is fairly simple minded and certainly not optimal, but it X; works. The idea is to cycle through the pegs from the start peg to the end X; peg picking up on disk at a time and putting it in the next legal spot. X; Only one disk can be 'picked up' at a time (holding ^disk). Productions X; alternate between time-to-act (picking up and putting down), time-to-move X; (looking at next peg), and time-to-print (printing the state of the X; towers). The towers are printed after a disk is put down. X X; The goal is to move from the peg on one end to the peg on the other. X; The goal has been reached when no pegs other than the goal peg have X; disks on them. X X; It requires 128 firings to solve the problem for 3 disks. X; ************************************************************ X X; elements are: X X; setup information X; start state X(literalize goal from to) X; end state X(literalize end is) X X; given info about the peg world X; relationships between entities X(literalize follows peg1 peg2) X(literalize smaller disk1 disk2) X X; state information X; program has three states : moving, acting, or printing X; only one state is valid at a given time X(literalize time-to-act) X(literalize time-to-move) X(literalize time-to-print) X X; current state of peg world X(literalize top disk peg) X(literalize under disk1 disk2) X(literalize holding disk) X(literalize on peg) X X; peg/disks vector holds the printing state of each peg X(literalize peg name disks) X(vector-attribute disks) X X; declare lisp function X(external print-towers) X X; start-task does what you think it does. X X(p start-task X { (goal ^from ^to ) } X --> X (remove ) X (make time-to-act) ; start act/move cycle X (make on ^peg ) ; set the starting point X (make end ^is )) ; define the end peg X X X; stop-task determines when the end has been reached X X(p stop-task ; end is reached when: X (on ^peg

) ; on a peg X (end ^is

) ; which is the end peg X (follows ^peg1

^peg2 ) ; which follows peg p1 X (follows ^peg1 ^peg2

) ; is followed by peg p2 X -(top ^disk ^peg ) ; both other pegs X -(top ^disk ^peg ) ; are empty X (time-to-move) X--> X (owrite (crlf) all finished (crlf)) X (halt)) X X X; state-change is used to skip pegs that either don't have disks on them X; or can't have the current disk put on it, i.e. if forces a move to X; the next peg when nothing else can be done. X X(p state-change X { (time-to-act) } X--> X (remove ) X (make time-to-move)) X X X X; pick-up-a-disk-from-a-full-peg picks up a disk from a peg with 3 disks X; pick-up and put-down productions must be separated because the X; peg stack is handled differently X X(p pick-up-a-disk-from-a-full-peg X (on ^peg

) ; current peg X { (top ^disk ^peg

) } ; find the top disk X { (under ^disk1 ^disk2 ) } ; is there one under it? X { (time-to-act) } ; is it time-to-act? X { (peg ^name

^disks ) } ; get peg stack X -(holding ^disk ) ; not already holding a disk? X--> X (make top ^disk ^peg

) ; reset top disk X (remove ) X (make holding ^disk ) ; now holding disk X (make peg ^name

^disks 0 ) ; update peg stack X (make time-to-move)) ; toggle act/move X X X; pick-up-a-disk-from-a-part-full-peg picks up a disk from a peg with 2 disks X X(p pick-up-a-disk-from-a-part-full-peg X (on ^peg

) ; current peg X { (top ^disk ^peg

) } ; find top disk X { (under ^disk1 ^disk2 ) } ; something under the top X { (time-to-act) } ; time-to-act? X { (peg ^name

^disks 0 ) } ; get part full peg stack X -(holding ^disk ) ; not holding a disk already? X--> X (remove ) X (make top ^disk ^peg

) ; reset top disk X (make peg ^name

^disks 0 0 ) ; reset peg stack X (make holding ^disk ) ; now holding disk X (make time-to-move)) ; toggle move/act X X; pick-up-a-disk-from-an-empty-peg takes a disk off a peg with 1 disk on it X X(p pick-up-a-disk-from-an-empty-peg X (on ^peg

) ; as above... X { (top ^disk ^peg

) } ; except for peg stack with X { (time-to-act) } ; with only one disk X { (peg ^name

^disks 0 0 ) } X -(under ^disk1 ^disk2 ) X -(holding ^disk ) X--> X (remove ) X (make holding ^disk ) X (make peg ^name

^disks 0 0 0) ; no disks on peg stack X (make time-to-move)) X X X; look-at-next-peg moves forward a peg and toggles move to act X X(p look-at-next-peg X { (on ^peg

) } X (follows ^peg1 ^peg2

) X { (time-to-move) } X--> X (remove ) X (make on ^peg ) X (make time-to-act)) X X X; put-on-a-full-peg puts a disk down on a peg that has 2 disks on it. X X(p put-on-a-full-peg X { (holding ^disk ) } X (on ^peg

) X { (top ^disk ^peg

) } X (smaller ^disk1 ^disk2 ) X { (time-to-act) } X { (peg ^name

^disks 0 ) } X--> X (remove ) X (make top ^disk ^peg

) X (make under ^disk1 ^disk2 ) X (make peg ^name

^disks ) X (make time-to-print)) X X X; put-on-a-part-full-peg puts a disk on a peg that has only one disk on it X X(p put-on-a-part-full-peg X { (holding ^disk ) } X (on ^peg

) X { (top ^disk ^peg

) } X (smaller ^disk1 ^disk2 ) X { (time-to-act) } X { (peg ^name

^disks 0 0 ) } X--> X (remove ) X (make top ^disk ^peg

) X (make under ^disk1 ^disk2 ) X (make peg ^name

^disks 0 ) X (make time-to-print)) X X X; put-on-an-empty-peg puts the disk being held on an empty peg by making it X; the top disk on the peg and updating the pegs print state X X(p put-on-an-empty-peg X { (holding ^disk ) } X (on ^peg

) X { (time-to-act) } X -(top ^disk ^peg

) X { (peg ^name

^disks 0 0 0) } X--> X (remove ) X (make peg ^name

^disks 0 0 ) X (make top ^disk ^peg

) X (make time-to-print)) X X X; print-peg-state takes the vector representation of the pegs and passes it X; to a franz function that prints them out X X(p print-peg-state X { (time-to-print) } X (peg ^name a ^disks ) X (peg ^name b ^disks ) X (peg ^name c ^disks ) X (peg ^name base ^disks ) X--> X (call print-towers ) X (remove ) X (make time-to-move)) X X X; the following are the 'facts' of the problem X; pegs are ordered a b c X(make follows ^peg1 b ^peg2 a) X(make follows ^peg1 c ^peg2 b) X(make follows ^peg1 a ^peg2 c) X X; disks are stacked 1 2 3 X(make top ^disk 1 ^peg a) X(make under ^disk1 2 ^disk2 1) X(make under ^disk1 3 ^disk2 2) X X; 1is the smallest disk and 2 is the medium disk X(make smaller ^disk1 1 ^disk2 2) X(make smaller ^disk1 2 ^disk2 3) X(make smaller ^disk1 1 ^disk2 3) X X; goal is to move the disks from peg a to peg c X(make goal ^from a ^to c) X X; peg a has the three disks on it X(make peg ^name a ^disks 1 2 3) X; the other pegs are empty X(make peg ^name b ^disks 0 0 0) X(make peg ^name c ^disks 0 0 0) X(make peg ^name base ^disks ----- ----- -----) X X;************************************************** X; Lisp program for printing out towers X X; purpose of this program is to demonstrate that ops5 CAN talk to franz X; under duress and to give an example of how its done. X; final result of printing is like the following: X; X; = | | X; === | | X; ===== | | X; ----- ----- ----- X X; positioning in the vector is from left to right and then top to bottom X; values in the vector are X ; 0 for the peg, X ; 1 for small disk, X ; 2 for medium disk, X ; 3 for large disk, X ; and who cares for the peg base. X X(defun print-towers() X (format t "~%~%~%") X X; loop to print out all 12 positions of the towers X; parameters are passed from ops to franz in a vector X X (do ((cnt 1 (add1 cnt))) X ((> cnt ($parametercount))) ; $parametercount is the X ; number of parameters X ; passed from ops X X (let ((nxt ($parameter cnt))) ; $parameter gets to each position X ; in the vector - cnt indicates X ; relative position X (cond ((eq nxt 0) (format t " | ")) X ((eq nxt 1) (format t " = ")) X ((eq nxt 2) (format t " === ")) X ((eq nxt 3) (format t " ===== ")) X (t (format t " ----- ")))) X (cond ((or (eq 3 cnt) (eq 6 cnt) (eq 9 cnt)) X (terpri))))) X X XOPS5 NOTES: X XOPS5 is has been made public domain by C. Lanny Forgy. There are, I believe, some Xrestrictions on transporting OPS5 to some foreign countries (which countries is pretty Xobvious). The code is copyrighted by Forgy, and anyone considering using it for Xcommercial purposes should probably contact him at CMU first. X XThe Vax Common Lisp and TI Explorer versions were ported by Dan Neiman of the XUniversity of Massachusetts, COINS Dept. They are *not* guaranteed to be 100% Xbug free, particularly in the I/O functions, but any bugs found should be Xmostly syntactic in nature. The TI Explorer takes advantage of some non-standard Xfeatures not normally in Common Lisp (such as the "e keyword) and is somewhat Xcleaner; the Vax Lisp version is more generic and will run on more systems. XThe Common Lisp versions are far from optimized, the major emphasis was on getting Xthem working and there are many idioms which could be expressed more compactly Xand efficiently. X XModifications to OPS itself. The ported versions of OPS are faithful to the manual with Xthe following exceptions, Common Lisp already possesses functions remove, write, and Xcall; the OPS5 functions have been renamed oremove, owrite, and ocall respectively. XThe OPS5 compilation functions have been modified to perform this renaming Xautomagically for RHS functions. The user will have to remember to use oremove Xwhen removing working memory from the top level. X XTest programs: There are not a lot of OPS5 benchmark programs available. The Xmonkey and bananas program was included in the original distribution. XThe sort and Towers of Hanoi problems demonstrate OPS5, but are not particularly good Xexemplars of the tasks that you want to solve using a production system. X X XQuestions about these versions of OPS5 can be directed to Dan Neiman, at electronic mail Xaddresses CSNET: dann@cs.umass.edu, dann@umass-cs.csnet X CompuServe: 72277,2604 X Real Mail: COINS Dept. X Lederle Graduate Research Center X UMass X Amherst, MA 01003 X X X echo shar: "a missing newline was added to 'OPSNET.JAN'" echo shar: "114 control characters may be missing from 'OPSNET.JAN'" SHAR_EOF if test 359936 -ne "`wc -c < 'OPSNET.JAN'`" then echo shar: "error transmitting 'OPSNET.JAN'" '(should have been 359936 characters)' fi fi echo shar: "extracting 'PERCEP.JAN'" '(13440 characters)' if test -f 'PERCEP.JAN' then echo shar: "will not over-write existing file 'PERCEP.JAN'" else sed 's/^ X//' << \SHAR_EOF > 'PERCEP.JAN' X X X Perceptrons & Neural Nets X (Two slightly different versions of the program) X January 1987 AI EXPERT X by Peter Reece X X XListing 1 X X5 ' PERCEPTRON VISION SYSTEM SIMULATION, Peter Reece 1986 X10 ' X11 ' X12 DEFINT A-X X13 ' IMAGE() = the sensory grid array X14 ' NEURALNET = the associative net - neural interconnections X15 ' SIZE**2 = number of cells in the sensory grid X16 ' SCAN = number of cells required to construct an 8-bit address X17 ' into the array NEURALNET() X18 ' LOOPSCAN = the number of iterations for scanning the sensory X19 ' grid - i.e. we look at scan cells at random X20 ' loopscan times X21 SIZE=16:SCAN=8:LOOPSCAN=SIZE*SIZE/SCAN X22 DIM IMAGE(SIZE,SIZE),NEURALNET(LOOPSCAN*SIZE*SIZE,1):CLS X30 PRINT" This program demonstrates how a very simple" X40 PRINT"pecpeptron is capable of analysing visual information." X45 PRINT:PRINT:PRINT X50 PRINT" Proceed as follows: " X51 PRINT:PRINT X60 PRINT" 1) Draw an object and decide if that object is a member of" X70 PRINT" a ojbect class one or two. Eg. A cup, saucer, and " X80 PRINT" plate might be class 1, a crayon class 2." X81 PRINT" 2) Train the perceptron to recognize objects" X82 PRINT" of a particular class by drawing various objects" X83 PRINT" from both classes." X84 PRINT" 3) Present various objects to the perceptron, (some" X85 PRINT" old objects may be used, as well as those that it" X86 PRINT" has never seen before), and see how successfully it" X87 PRINT" classifies new ojects as beloging to the correct class." X88 PRINT:PRINT X90 Q$="Press [enter] to begin a training session.":GOSUB 3000:CLS X98 ' X99 ' X100 ' X110 '********** Reach here to begin a training session. ********* X120 CLS:FOR I=1 TO SIZE:FOR J=1 TO SIZE:IMAGE(I,J)=0:NEXT:NEXT X130 LOCATE 10,50:PRINT"=== TRAINING SESSION ====" X135 LOCATE 11,50:INPUT"Draw class 1 or 2";CLASS X136 IF CLASS=1 THEN CLASS=0 ELSE CLASS=1 X140 ' X145 GOSUB 1000 X150 FOR I=1 TO LOOPSCAN:GOSUB 2000 X160 NEURALNET(INDEX,CLASS)=1 X210 NEXT X220 LOCATE 2,5:Q$="Want to conduct another training session" 230 GOSUB 3000:IF Q$="Y" THEN 110 X231 ' X232 ' X233 ' X400 ' *********** Here to classify an object ************ X410 FOR I=1 TO SIZE:FOR J=1 TO SIZE:IMAGE(I,J)=0:NEXT:NEXT X420 CLS:LOCATE 10,50:PRINT"=== CLASSIFICATION SESSION ====" X422 ' X450 GOSUB 1000:MEMBER=0:NONMEMBER=0 X500 FOR I=1 TO LOOPSCAN:GOSUB 2000 X540 IF NEURALNET(INDEX,0)=1 THEN MEMBER=MEMBER+1 X550 IF NEURALNET(INDEX,1)=1 THEN NONMEMBER=NONMEMBER+1 X560 NEXT X571 LOCATE 23,2:PRINT SPC(78) X573 LOCATE 12,50: PRINT"Ratio is ";MEMBER;"/";NONMEMBER X574 LOCATE 13,50: PRINT " favoring class "; X576 IF MEMBERSIZE THEN K=0:KZ=KZ+1:?" "; X661 IF KZ>3 THEN KZ=0:?:KK=KK+1 X662 IF KK>SIZE THEN KK=0:? X665 NEXT:NEXT X670 ?"Emptying Neural Network...":FOR I=1 TO LOOPSIZE*SIZE*SIZE X680 FOR J=0 TO 1 X690 NEURALNET(I,J)=0:NEXT:NEXT:GOTO 100 X700 :CLS:PRINT"Bye!":STOP X998 ' X999 ' X1000 ' *********** Interactive Object drawing *********** X1005 RR=5:CC=20:ROW=1:CLM=1 X1006 LOCATE 23,2 X1010 PRINT"[D],[U],[L],[R] to move. [.] to plot, [ ] to erase, [S] to stop." X1061 FOR I=1 TO SIZE+1 X1062 LOCATE RR+I,CC:PRINT "|";:LOCATE RR+I,CC+17:PRINT "|"; X1063 LOCATE RR,CC+I:PRINT "-";:LOCATE RR+17,CC+I:PRINT"-"; X1064 NEXT X1070 LOCATE ROW+RR,CLM+CC X1080 A$=INKEY$:IF A$="" THEN 1080 X1090 IF A$="U" THEN ROW=ROW-1 X1100 IF A$="D" THEN ROW=ROW+1 X1110 IF A$="R" THEN CLM=CLM-1 X1120 IF A$="L" THEN CLM=CLM+1 X1130 IF CLM > SIZE THEN CLM=SIZE X1140 IF CLM < 1 THEN CLM=1 X1160 IF ROW < 1 THEN ROW=1 X1170 IF ROW > SIZE THEN ROW=SIZE 1171 LOCATE 5,5:PRINT "ROW=";ROW;" CLM=";CLM; X1190 LOCATE ROW+RR,CLM+CC X1191 IF A$="." THEN PRINT"*":LOCATE ROW+RR,CLM+CC:IMAGE(ROW,CLM)=1 X1194 IF A$=" " THEN PRINT" ":LOCATE ROW+RR,CLM+CC:IMAGE(ROW,CLM)=0 X1196 IF A$="S" THEN LOCATE 10,1:PRINT"Object completed":GOTO 1210 X1205 GOTO 1080 X1210 PRINT "ONE MOMENT...":RETURN X1999' X2000 ' Calculate an SCAN digit address into NEURALNET() X2001 ' by scanning any 8 cells of IMAGE() at random X2002 ' If a cell has an active pixel, it is considered on, X2003 ' else it is considered off. Hence a SCAN digit binary address. X2005 INDEX=SIZE*SIZE*(I-1) X2010 FOR J=1 TO SCAN X2020 FIRST=INT(RND*SIZE+1):SECOND=INT(RND*SIZE+1) X2040 INDEX=INDEX+IMAGE(FIRST,SECOND)*2^J X2050 NEXT:RETURN X2999 ' X3000 PRINT Q$;:INPUT " ";Q$ X3010 Q$=LEFT$(Q$,1):RETURN X X XListing 2 X X10' Simulation of a Simple Neural Net X20 ' IMAGE = the sensory grid array X30 ' NEURALNET = the associative net - neural interconnections X40 ' SIZE^2 = number of cells in the sensory grid X50 ' SCAN = number of cells required to construct an 8-bit address X60 ' into the array NEURALNET() X70 ' LSCAN = the number of iterations for scanning the sensory X80 ' grid - i.e. we look at scan cells at random X90 ' loopscan times X100 DEFINT A-Z:SIZE=16:SCAN=8:LSCAN=(SIZE^2)/SCAN X120 DIM IMAGE(SIZE,SIZE),NEURALNET(LSCAN*(SIZE^2),2) X130 GOSUB 6000:' Intro message X140 ' X150 '************ Training session. ************ X155 RANDOMIZE 5:' Init random X160 CLS: LOCATE 10,50:PRINT"=== TRAINING SESSION ====" X161 LOCATE 12,50:' Put up a prompt X162 Q$="Automatic training" X163 GOSUB 3000:' Select Training X164 IF Q$<>"Y" THEN 170:' Manual Training X165 GOSUB 4000:GOTO 400:' Automatic Training X166 ' X170 LOCATE 11,50 X175 INPUT"Draw class 1 or 2";CLASS:' Select a class X180 IF CLASS>2 THEN CLASS=2:' for this object X190 IF CLASS<2 THEN CLASS=1:' within range X200 GOSUB 1000:' Draw an object X210 FOR I=1 TO LSCAN:' Calculate X220 GOSUB 2000:' indicies into X230 NEURALNET(INDEX,CLASS)=1:' neuralnet X240 NEXT:' for this class 250 LOCATE 2,5 X260 Q$="Want to conduct more training":' loop through more X270 GOSUB 3000:IF Q$="Y" THEN 160:' training X271 ' X272 ' X273 ' X400 ' *********** Classification Session ************ X420 CLS:LOCATE 10,50:PRINT"=== CLASSIFICATION SESSION ====" X430 ' X431 RANDOMIZE 5:' Init random X440 GOSUB 1000:' Draw an object X450 MEMBER=0:NONMEMBER=0:' Init member count X500 FOR I=1 TO LSCAN:' Calculate X510 GOSUB 2000:' indicies X540 IF NEURALNET(INDEX,1)=1 THEN MEMBER=MEMBER+1 X550 IF NEURALNET(INDEX,2)=1 THEN NONMEMBER=NONMEMBER+1 X551 IF NEURALNET(INDEX,1)=0 AND NEURALNET(INDEX,2)=0 THEN 553 X552 GOTO 560 X553 I=I-1:' Null class found X560 NEXT X571 LOCATE 23,2:PRINT SPC(78) X573 LOCATE 12,50: PRINT"Ratio is ";MEMBER;"/";NONMEMBER X574 LOCATE 13,50: PRINT " favouring class "; X576 IF MEMBER1 THEN 590 X589 LOCATE 9,50:?" * Ratios is close. *" X590 LOCATE 14,50:Q$="Classify another object":GOSUB 3000 X600 IF Q$="Y" THEN 400 X601' X610 CLS:?:?:?:?:Q$="Want to see NEURALNET":GOSUB 3000 X620 IF Q$="Y" THEN GOSUB 7000 X670 ?"Emptying Neural Network..." X671 FOR I=1 TO LSCAN*(SIZE^2) X680 FOR J=1 TO 2 X690 NEURALNET(I,J)=0 X691 NEXT X692 NEXT:GOTO 150 X998 ' X999 ' X1000 ' *********** Interactive Object drawing *********** X1002 FOR I=1 TO SIZE:FOR J=1 TO SIZE:IMAGE(I,J)=0:NEXT:NEXT X1005 RR=5:CC=20:ROW=1:CLM=1 X1006 LOCATE 23,2 X1010 PRINT"[D],[U],[L],[R] to move. [.] to plot, [ ] to erase, [S] to stop." X1061 FOR I=1 TO SIZE+1 X1062 LOCATE RR+I,CC:PRINT "|";:LOCATE RR+I,CC+17:PRINT "|"; X1063 LOCATE RR,CC+I:PRINT "-";:LOCATE RR+17,CC+I:PRINT"-"; X1064 NEXT X1070 LOCATE ROW+RR,CLM+CC X1080 A$=INKEY$:IF A$="" THEN 1080 X1090 IF A$="U" THEN ROW=ROW-1 X1100 IF A$="D" THEN ROW=ROW+1 X1110 IF A$="R" THEN CLM=CLM-1 1120 IF A$="L" THEN CLM=CLM+1 X1130 IF CLM > SIZE THEN CLM=SIZE X1140 IF CLM < 1 THEN CLM=1 X1160 IF ROW < 1 THEN ROW=1 X1170 IF ROW > SIZE THEN ROW=SIZE X1171 LOCATE 5,5:PRINT "ROW=";ROW;" CLM=";CLM; X1190 LOCATE ROW+RR,CLM+CC X1191 IF A$="." THEN PRINT CHR$(219):LOCATE ROW+RR,CLM+CC:IMAGE(CLM,ROW)=1 X1194 IF A$=" " THEN PRINT" ":LOCATE ROW+RR,CLM+CC:IMAGE(CLM,ROW)=0 X1196 IF A$="S" THEN LOCATE 10,1:PRINT"Object completed":GOTO 1210 X1205 GOTO 1080 X1210 PRINT "ONE MOMENT...":RETURN X1998' X1999' X2000 ' Calculate a SCAN digit address into NEURALNET() X2001 ' by scanning any SCAN cells of IMAGE() at random X2002 ' If a cell has an active pixel, it is considered on, X2003 ' else it is considered off. Hence a SCAN digit binary address. X2004 ' Resultant index is in the range 0 and up in size^2 X2005 ' blocks. The address within a block is determined by X2006 ' the image(a,b) as a power of 2 (line 2040). X2009 INDEX=(SIZE^2)*(I-1) X2010 FOR J=0 TO SCAN-1 X2020 FIRST=INT(RND*SIZE)+1:SECOND=INT(RND*SIZE)+1 X2040 INDEX=INDEX+IMAGE(FIRST,SECOND)*2^J X2050 NEXT:RETURN X2999 ' X3000' Issue a prompt using q$, and return q$=Y/N X3001 PRINT Q$;:INPUT Q$ X3010 Q$=LEFT$(Q$,1): X3050 RETURN X3099' X4000' Train the neural net on vertical vs. horizontal lines X4001 ?"Note: It takes a while to scan each object, but more " X4002 ?" ojects mean more accurate classification." X4003 CLASS=1:RANDOMIZE 5 X4004 INPUT"How many objects of Class One ";KNT X4010 FOR KLOOP=1 TO KNT:CLS: LOCATE 10,30:?KLOOP;" of ";KNT X4011 FOR I=1 TO SIZE+1 X4012 LOCATE I,SIZE:?"|";:LOCATE SIZE,I:? "-"; X4013 NEXT X4014 ?"Object Class One"; X4015 ' Create one horizontal line of length k X4019 FOR I=1 TO SIZE:FOR J=1 TO SIZE:IMAGE(I,J)=0:NEXT:NEXT X4020 KLEN=INT(RND*SIZE+1):IF KLEN<2 THEN 4020 X4021 MPOS=INT(RND*SIZE)+1:NPOS=INT(RND*SIZE)+1 X4022 IF NPOS+KLEN>SIZE THEN 4020 X4023 IF NPOS>=KLEN THEN 4020 X4025 FOR A=NPOS TO KLEN X4026 IMAGE(A,MPOS)=1:LOCATE MPOS,A:?CHR$(223); X4027 NEXT X4029 'Now place this image into nerualnet X4030 LOCATE 11,30:?"Scanning object" X4032 LOCATE 12,30:?"Len=";KLEN;" Start=";NPOS;",";MPOS; X4090 FOR I=1 TO LSCAN:GOSUB 2000 4091 NEURALNET(INDEX,CLASS)=1 X4092 NEXT X4094 NEXT:CLS X4100 INPUT"How many objects of Class Two ";KNT X4105 CLASS=2:RANDOMIZE 5 X4110 FOR KLOOP=1 TO KNT:CLS:LOCATE 10,30:?KLOOP;" of ";KNT X4111 FOR I=1 TO SIZE+1 X4112 LOCATE I,SIZE:?"|";:LOCATE SIZE,I:? "-"; X4113 NEXT X4114 ?"Object Class Two"; X4120 FOR I=1 TO SIZE:FOR J=1 TO SIZE:IMAGE(I,J)=0:NEXT:NEXT X4130 KLEN=INT(RND*SIZE+1):IF KLEN<2 THEN 4130 X4135 MPOS=INT(RND*SIZE)+1:NPOS=INT(RND*SIZE)+1 X4140 IF NPOS+KLEN>SIZE THEN 4130 X4141 IF NPOS>=KLEN THEN 4130 X4145 FOR A=NPOS TO KLEN X4150 IMAGE(MPOS,A)=1:LOCATE A,MPOS:?CHR$(219); X4153 NEXT X4154 'Now place this image into nerualnet X4155 LOCATE 11,30:?"Scanning object" X4156 LOCATE 12,30:?"Len=";KLEN;" Start=";NPOS;",";MPOS; X4160 FOR I=1 TO LSCAN:GOSUB 2000 X4170 NEURALNET(INDEX,CLASS)=1 X4180 NEXT X4190 NEXT:CLS X4200 RETURN X4998' X4999' X6000' Put up an intro message X6010 CLS:PRINT" This program demonstrates how a very simple" X6040 PRINT"pecpeptron is capable of analysing visual information." X6045 PRINT:PRINT:PRINT X6050 PRINT" Proceed as follows: " X6051 PRINT:PRINT X6060 PRINT" 1) Draw an object and decide if that object is a member of" X6070 PRINT" a ojbect class one or two. Try vertical versus" X6080 PRINT" horizontal lines to start." X6081 PRINT" 2) Train the neural net to recognize objects" X6082 PRINT" of a particular class by drawing various objects" X6083 PRINT" from both classes. (This may be done automatically)." X6084 PRINT" 3) Present various objects to the net, (some" X6085 PRINT" old objects may be used, as well as those that it" X6086 PRINT" has never seen before), and see how successfully it" X6087 PRINT" classifies new ojects as belonging to the correct class." X6088 PRINT" This simple simulation will make mistakes, but should" X6089 PRINT" perform better or even much better than at random." X6090 PRINT:PRINT X6091 Q$="Ready.":GOSUB 3000:CLS X6100 RETURN X6999' X7000' Display the contents of the neural network X7030 K=0:KK=0:KZ=0 X7031 FOR I=1 TO LSCAN*SIZE^2 X7040 FOR J=1 TO 2 X7050 A=NEURALNET(I,J):IF A=1 THEN ?"*"; ELSE ?"."; 7060 K=K+1:IF K>SIZE THEN K=0:KZ=KZ+1:?" "; X7061 IF KZ>3 THEN KZ=0:?:KK=KK+1 X7062 IF KK>SIZE THEN KK=0:? X7065 NEXT X7066 NEXT X7070 RETURN X X echo shar: "a missing newline was added to 'PERCEP.JAN'" echo shar: "74 control characters may be missing from 'PERCEP.JAN'" SHAR_EOF if test 13440 -ne "`wc -c < 'PERCEP.JAN'`" then echo shar: "error transmitting 'PERCEP.JAN'" '(should have been 13440 characters)' fi fi exit 0 # End of shell archive -- --------------- C'est la vie, C'est la guerre, C'est la pomme de terre Mail: Imagen Corp. 2650 San Tomas Expressway Santa Clara, CA 95052-8101 UUCP: ...{decvax,ucbvax}!decwrl!imagen!turner AT&T: (408) 986-9400