turner@imagen.UUCP (D'arc Angel) (01/19/87)
here it is and rather lengthly, cat all nine parts together and shar
it, don't forget to remove my .signature at the end of each file.
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create:
# AIAPP.JAN
# CONTNT.JAN
# EXPERT.JAN
# FILES.JAN
# OPSNET.JAN
# PERCEP.JAN
# This archive created: Sun Jan 18 19:24:39 1987
# By: D'arc Angel (The Houses of the Holy)
export PATH; PATH=/bin:/usr/bin:$PATH
echo shar: "extracting 'AIAPP.JAN'" '(29884 characters)'
if test -f 'AIAPP.JAN'
then
echo shar: "will not over-write existing file 'AIAPP.JAN'"
else
sed 's/^ X//' << \SHAR_EOF > 'AIAPP.JAN'
X
X
X AI Apprentice
X by Bill Thompson and Bev Thompson
X "Creating Expert Systems from Examples"
X January 1987 AI EXPERT
X
X
X
XFigure 1.
X
X batch# part# power symptom Problem
X
X b 312 ac no power powersupply
X a 312 ac weak gear bad
X c 412 dc sparking powersupply
X d 412 ac no power wiring
X c 212 dc sparking powersupply
X c 412 ac weak wiring
X a 212 ac no power gear bad
X b 412 dc weak wiring
X b 212 ac weak gear bad
X
X
X
XFigure 2 - A decision tree produced from the data in Table 1.
X
X
X batch# part# power symptom Result
X
X b 412 ac weak gear bad
X a 212 dc weak powersupply
X d 212 dc sparking wiring
X d 412 ac no power powersupply
X
X
X
XTable 1 - A training set of data for a repair problem.
X
X If batch# is a
X then result is gear bad.
X
X If batch# is b
X and part# is 212
X then result is gear bad.
X
X If batch# is b
X and part# is 312
X then result is powersupply.
X
X If batch# is b
X and part# is 412
X then result is wiring.
X
X If batch# is c
and power is ac
X then result is wiring.
X
X If batch# is c
X and power is dc
X then result is powersupply.
X
X If batch# is d
X then result is wiring.
X
X
X batch# ?
X a: ---------------------------------------------gear bad
X b:part# ?
X 212: ---------------------------------------- gear bad
X 312: ---------------------------------------- powersupply
X 412: ---------------------------------------- wiring
X c:power??
X ac: ----------------------------------------- wiring
X dc: ----------------------------------------- powersupply
X d: --------------------------------------------- wiring
X
X
X
XTable 2 - A new set of data collected for the repair problem. This data
X is used for validation of the solution.
X
X
Xclinical descript distribution group Result
X
Xfever upper resp. epidemic respiratory parainfluenza
Xchills lower resp. local enteric adenovirus
Xrash mid resp. children exanthems mumps
Xswelling hospital latent rhinovirus
Xmalaise youngadults echo
Xheadache universal coxasackie
Xcough varicella
X
X
X rubella
X
XTable 3 - Definitions of results and attributes for identifying viruses.
X
Xlevel type of subject programming cover type basic Author
X software matter covered language
Xintro/adv gen/spec gen/spec no/yes soft/hard no/yes
X1. 1. 4. 3. soft 5. Jones
X2. 5. 5. 4. soft 1. Smith
X1. 1. 1. 3. soft 1. Fisher
X1. 1. 1. 3. hard 5. Mitchell
X1. 1. 1. 1. soft 1. Argyle
X5. 1. 5. 5. hard 1. Chang
X
X
X
Table 4 - An example set for selecting a textbook. This set was produced
X using the Flexigrid program.
X
Xsubject matter ? (gen/spec)
X < 2.50: programming covered ? (no/yes)
X < 2.00: ---------------------------------- Concepts
X >=2.00: cover ?
X hard: -------------------------- Today's
X soft: -------------------------- Information
X >=2.50: level ? (intro/adv)
X < 1.50: -------------------------------- Society
X >=1.50: level ? (intro/adv)
X < 3.50: ------------------------ Applications
X >=3.50: ------------------------ Data_structures
X
X
Xupply of serotinous cones
X.
X
Xprompt 10/acre adequate
XAre 10 trees per acre adequate to seed the area ?
X.
X
Xtrans 10/acre adequate
X10 per acre is /not/ adequate
X.
X
Xprompt burning planned
XHas a prescribed burning been planned ?
X.
X
Xtrans burning planned
Xburning is /not/ planned
X.
X
Xtrans use seed tree
XYou should /not/ use seed trees to seed the area
X.
X
15
Xif branch 11 is yes
Xand pine desired is yes
Xand pine suited is yes
Xand desirable seed is yes
Xand serotinous cones is yes
Xand 10/acre adequate is yes
Xand burning planned is no
Xthen silviculture method is clearcut
Xand branch 17 is yes .
X
Xtrans silvaculture method
Xthe best silviculture method to use
X.
X
X16
Xif branch 11 is yes
Xand pine desired is yes
Xand pine suited is yes
Xand desirable seed is yes
Xand serotinous cones is yes
Xand 10/acre adequate is no
Xthen silviculture method is clearcut
Xand branch 17 is yes .
X
X17
Xif branch 11 is yes
Xand pine desired is yes
Xand pine suited is yes
Xand desirable seed is yes
Xand serotinous cones is no
Xand two harvests wanted is yes
Xand two harvests possible is yes
Xthen silviculture method is shelterwood
Xand branch 17 is yes .
X
Xprompt two harvests wanted
XDo you want to do two commercial harvests on this area ?
X.
X
Xtrans two harvests wanted
Xtwo commercial harvests are /not/ wanted
X.
X
Xprompt two harvests possible
XIs it possible to get two harvests from this area ?
X.
X
Xtrans two harvests possible
Xtwo harvests can /not/ be done on this area
X.
X
X18
Xif branch 11 is yes
Xand pine desired is yes
Xand pine suited is yes
Xand desirable seed is yes
Xand serotinous cones is no
Xand two harvests wanted is yes
Xand two harvests possible is no
then silviculture method is clearcut
Xand branch 17 is yes .
X
X19
Xif branch 11 is yes
Xand pine desired is yes
Xand pine suited is yes
Xand desirable seed is yes
Xand serotinous cones is no
Xand two harvests wanted is no
Xthen silviculture method is clearcut
Xand branch 17 is yes .
X
X20
Xif branch 11 is yes
Xand pine desired is yes
Xand pine suited is yes
Xand desirable seed is no
Xthen silviculture method is clearcut
Xand branch 17 is yes .
X
X21
Xif branch 11 is yes
Xand pine desired is yes
Xand pine suited is no
Xthen convert is yes
Xand recommend is convert .
X
Xtrans convert
Xyou should /not/ convert the area to some more desirable kind of tree
X.
X
X22
Xif branch 11 is yes
Xand pine desired is no
Xthen convert is yes
Xand recommend is convert .
X
X
X26
Xif branch 17 is yes
Xand adequate seedbed is yes
Xthen branch 18 is yes .
X
Xprompt adequate seedbed
XIs there an adequate seedbed for planting ?
X.
X
Xtrans adequate seedbed
Xthere is /not/ an adequate seedbed for planting
X.
X
X27
Xif branch 17 is yes
Xand adequate seedbed is no
Xthen prepare site is yes
Xand branch 18 is yes .
X
trans prepare site
Xthe site should /not/ be prepared before planting
X.
X
X28
Xif branch 18 is yes
Xand silviculture method is shelterwood
Xthen use natural seeding is yes
Xand recommend is use natural seeding .
X
Xtrans use natural seeding
Xnatural seeding techniques should /not/ be used
X.
X
X29
Xif branch 18 is yes
Xand silviculture method is clearcut
Xand improved stock is yes
Xthen plant is yes
Xand recommend is plant .
X
Xprompt improved stock
XIs there improved planting stock available ?
X.
X
Xtrans improved stock
Xthere is /not/ improved stock available
X.
X
Xtrans plant
Xsince there is better stock available you can /not/ plant using that stock
X.
X
X30
Xif branch 18 is yes
Xand silviculture method is clearcut
Xand improved stock is no
Xand good cone supply is yes
Xthen scatter cones is yes
Xand recommend is scatter cones .
X
Xprompt good cone supply
XIs there a good supply of serotinous cones on the area ?
X.
X
Xtrans good cone supply
Xthere is /not/ a good cone supply
X.
X
Xtrans scatter cones
Xyou should /not/ scatter the supply of serotinous cones over the area
X.
X
X31
Xif branch 18 is yes
Xand silviculture method is clearcut
Xand improved stock is no
Xand good cone supply is no
Xthen direct seed is yes
Xand recommend is direct seed .
X
Xtrans direct seed
XSince the cone supply is inadequate, you should /not/ directly seed the
area
X.
X
X
X-------------------------------------------------------------------------
X
XThe following comments are not a part of the knowledge base. If you
Xtry to run the knowledge base this part of the file should be removed
X
X
XAbbreviated KEY
X
X1. stocking good is yes ............................. 2
X1. stocking good is no ............................. 10
X 2. avg < 5 is yes ................................ 3
X 2. avg < 5 is no ................................. 4
X3. 2000 + per acre is yes ..........WEED OR CLEAN.... 8
X3. 2000 + per acre is no ............................ 8
X 4. age is mature ................................. 11
X 4. age is immature ............................... 5
X5. site index > 60 is yes ........................... 6
X5. site index > 60 is no ............................ 9
X 6. product size is large ......................... 7
X 6. product size is small ......................... 9
X7. 120 + basal area is yes .........THIN............. 9
X7. 120 + basal area is no ........................... 9
X 8. severe competition is yes ....RELEASE.......... 9
X 8. severe competition is no ...................... 9
X9. high risk is yes ................................. CONTROL IF FEASIBLE
X9. high risk is no .................................. WAIT
X 10. other resources is yes ....................... MAINTAIN
X 10. other resources is no ........................ 11
X11. pine suitable is yes ............................. 12
X11. pine suitable is no .............................. CONVERT
X 12. desirable seed is yes ........................ 13
X 12. desirable seed is no ........USE CLEARCUT..... 17
X13. serotinous cones is yes .......................... 14
X13. serotinous cones is no ........................... 16
X 14. 10/acre adequate is yes ...................... 15
X 14. 10/acre adequate is no ......USE CLEARCUT..... 17
X15. burning planned is yes ........................... USE SEED TREE
X15. burning planned is no ...........USE CLEARCUT..... 17
X 16. two harvests wanted is yes ..USE SHELTERWOOD.. 17
X 16. two harvests wanted is no ...USE CLEARCUT..... 17
X17. adequate seedbeds is yes ......................... 18
X17. adequate seedbeds is no .........PREPARE SITE..... 18
X 18. silviculture method is shelterwood ........... USE NATURAL SEEDING
X 18. silviculture method is clearcut .............. 19
X19. improved stock is yes ............................ PLANT
X19. improved stock is no ............................. 20
X 20. good cone supply is yes ...................... SCATTER CONES
X 20. good cone supply is no ....................... DIRECT SEED
X
X
X
XThe purpose of this exercise is to show how a knowledge base can be
designed to directly follow a key. There are several places where the
XKB could have been made more efficient, but this would have meant
Xdeparting from the order of the key. You might find it an interesting
Xexercise to explore other ways this same information could have been
Xrepresented in the KB.
X
XThe key appears in the Managers Handbood for Jack Pine in the North Central
XStates. The Handbook was produced by the North Central Forest Experiment
XStation of the Forest Service of the U.S. Dept. of Agriculture. Our
Xintention in writing this knowledge base is to show the structure of a
Xknowledge base written for a backward chaining inference engine directly
Xfrom an existing document. If this KB were to be actually used, it would
Xneed to have clearer questions and more explanations to the user. These
Xexplanations are provided in the handbook and could be easily incorporated
Xinto the knowledge base.
X
XThe knowledge base will run on the expert system shell MicroExpert which is
Xan example of a backward chaining inference engine. MicroExpert is
Xavailable from McGraw-Hill for $49.95 and can be ordered by calling 1-800-
X628-0004 or, in NY, 212-512-2999 . The knowledge base is described in the
Xcolumn AI Apprentice which appears in the November issue of AI Expert
Xmagazine. The design details of the inference engine which runs the KB is
Xdescribed in the article "Inside an Expert System" in the April 1985
Xisuue of BYTE magazine.
X
XMicroExpert, AI Apprentice and "Inside an Expert System" are all written
Xby Bev and Bill Thompson . We're always happy to hear about your thoughts
Xand comments, good or bad on any of our work. Contact us at the address
Xbelow, on Compuserve or BIX. Our Compuserve id is 76703,4324 and we can be
Xreached by Easyplex or in the AI Expert Forum. Our BIX id is bbt and we
Xmay be contacted via BIXmail or by leaving comments in the MicroExpert
Xconference.
X
XBill and Bev Thompson
XR.D. 2 Box 430
XNassau, N.Y. 12123
X
X
X TREES.PRO
X PROLOG program
X
X
X/* This PDPROLOG program implements a knowledge base based upon the
X following key:
X
X To run the program type "go."
X Caution - This program can be very S L O W.
X
XAbbreviated KEY
X
X1. stocking good is yes ............................. 2
X1. stocking good is no ............................. 10
X 2. avg < 5 is yes ................................ 3
X 2. avg < 5 is no ................................. 4
X3. 2000 + per acre is yes ..........WEED OR CLEAN.... 8
3. 2000 + per acre is no ............................ 8
X 4. age is mature ................................. 11
X 4. age is immature ............................... 5
X5. site index > 60 is yes ........................... 6
X5. site index > 60 is no ............................ 9
X 6. product size is large ......................... 7
X 6. product size is small ......................... 9
X7. 120 + basal area is yes .........THIN............. 9
X7. 120 + basal area is no ........................... 9
X 8. severe competition is yes ....RELEASE.......... 9
X 8. severe competition is no ...................... 9
X9. high risk is yes ................................. CONTROL IF FEASIBLE
X9. high risk is no .................................. WAIT
X 10. other resources is yes ....................... MAINTAIN
X 10. other resources is no ........................ 11
X11. pine suitable is yes ............................. 12
X11. pine suitable is no .............................. CONVERT
X 12. desirable seed is yes ........................ 13
X 12. desirable seed is no ........USE CLEARCUT..... 17
X13. serotinous cones is yes .......................... 14
X13. serotinous cones is no ........................... 16
X 14. 10/acre adequate is yes ...................... 15
X 14. 10/acre adequate is no ......USE CLEARCUT..... 17
X15. burning planned is yes ........................... USE SEED TREE
X15. burning planned is no ...........USE CLEARCUT..... 17
X 16. two harvests wanted is yes ..USE SHELTERWOOD.. 17
X 16. two harvests wanted is no ...USE CLEARCUT..... 17
X17. adequate seedbeds is yes ......................... 18
X17. adequate seedbeds is no .........PREPARE SITE..... 18
X 18. silviculture method is shelterwood ........... USE NATURAL SEEDING
X 18. silviculture method is clearcut .............. 19
X19. improved stock is yes ............................ PLANT
X19. improved stock is no ............................. 20
X 20. good cone supply is yes ...................... SCATTER CONES
X 20. good cone supply is no ....................... DIRECT SEED
X
X
X
XThe purpose of this exercise is to show how an expert system can be
Xdesigned to directly follow a key. There are several places where the
Xprogram could have been made more efficient, but this would have meant
Xdeparting from the order of the key. You might find it an interesting
Xexercise to explore other ways this same information could have been
Xrepresented in the program.
X
XThe key appears in the Managers Handbood for Jack Pine in the North Central
XStates. The Handbook was produced by the North Central Forest Experiment
XStation of the Forest Service of the U.S. Dept. of Agriculture. Our
Xintention in writing this knowledge base is to show the structure of a
Xknowledge base written for a backward chaining inference engine directly
Xfrom an existing document. If this KB were to be actually used, it would
Xneed to have clearer questions and more explanations to the user. These
Xexplanations are provided in the handbook and could be easily incorporated
Xinto the knowledge base.
X
This program is similar to the KB for the expert system shell
XMicroExpert which is an example of a backward chaining inference engine.
XMicroExpert is available from McGraw-Hill for $49.95 and can be ordered
Xby calling 1-800-628-0004 or, in NY, 212-512-2999 .
XThe knowledge base is described in the AI Apprentice column which appears
Xin the November issue of AI Expert magazine.
XThe design details of the inference engine which runs the KB is
Xdescribed in the article "Inside an Expert System" in the April 1985
Xisuue of BYTE magazine.
X
XMicroExpert, AI Apprentice and "Inside an Expert System" are all written
Xby Bev and Bill Thompson . We're always happy to hear about your thoughts
Xand comments, good or bad on any of our work. Contact us at the address
Xbelow, on Compuserve or BIX. Our Compuserve id is 76703,4324 and we can be
Xreached by Easyplex or in the AI Expert Forum. Our BIX id is bbt and we
Xmay be contacted via BIXmail or by leaving comments in the MicroExpert
Xconference.
X
XBill and Bev Thompson
XR.D. 2 Box 430
XNassau, N.Y. 12123 */
X
X/* Control - In MicroExpert terms, the goal of the consultation is
X recommendation */
X
Xgo :- clear_kb,
X give_advice.
Xgive_advice :- recommendation(X),
X fail.
Xgive_advice :- print_advice.
X
X/* The rules -
X These are implemented this way to mimic the MicroExpert rule set.
X Looking at them side by side should show the similarities. */
X
Xfact(branch8,yes) :- fact('stocking good',yes),
X fact('avg < 5',yes),
X fact('2000+ per acre',yes),
X recommend('The stand of jack pine must be weeded and cleaned.').
Xfact(branch8,yes) :- fact('stocking good',yes),
X fact('avg < 5',yes),
X fact('2000+ per acre',no).
Xfact(branch9,no) :- fact('stocking good',yes),
X fact('avg < 5',no),
X fact(age,mature),
X assertz(fact(branch11,yes)).
Xfact(branch11,yes) :- fact('stocking good',yes),
X fact('avg < 5',no),
X fact(age,mature),
X assertz(fact(branch9,no)).
Xfact(branch9,yes) :- fact('stocking good',yes),
X fact('avg < 5',no),
X fact(age,immature),
X fact('site index > 60',yes),
X fact('product size',large),
fact('120+ basal area',yes),
X recommend('It is important to thin the area').
Xfact(branch9,yes) :- fact('stocking good',yes),
X fact('avg < 5',no),
X fact(age,immature),
X fact('site index > 60',yes),
X fact('product size',large),
X fact('120+ basal area',no).
Xfact(branch9,yes) :- fact('stocking good',yes),
X fact('avg < 5',no),
X fact(age,immature),
X fact('site index > 60',yes),
X fact('product size',large).
Xfact(branch9,yes) :- fact('stocking good',yes),
X fact('avg < 5',no),
X fact(age,immature),
X fact('site index > 60',yes).
Xrecommendation(maintain) :-
X fact('stocking good',no),
X fact('other resources',yes),
X recommend('You should maintain the stand in its present condition').
Xfact(branch11,yes) :- fact('stocking good',no),
X fact('other resources',no).
Xfact(branch9,yes) :- fact(branch8,yes),
X fact('severe competition',yes),
X recommend('Competing trees should be eliminated.').
Xfact(branch9,yes) :- fact(branch8,yes),
X fact('severe competition',no).
Xrecommendation(control) :-
X fact(branch9,yes),
X fact('high risk',yes),
X recommend('The current area should be controlled, if at all feasible.').
Xrecommendation(wait) :-
X fact(branch9,yes),
X fact('high risk',no),
X recommend('You should wait before doing anything else to this stand.').
Xrecommendation('use seed tree') :-
X fact(branch11,yes),
X fact('pine desired',yes),
X fact('pine suited',yes),
X fact('desirable seed',yes),
X fact('serotinous cones',yes),
X fact('10/acres adequate',yes),
X fact('burning planned',yes),
X recommend('You should use seed trees to seed the area.').
Xfact(branch17,yes) :-
X fact(branch11,yes),
X fact('pine desired',yes),
X fact('pine suited',yes),
X fact('desirable seed',yes),
X fact('serotinous cones',yes),
X fact('10/acres adequate',yes),
X fact('burning planned',no),
X add_fact(silvaculture,clearcut),
X recommend('The best silvaculture method to use is clearcut.').
fact(branch17,yes) :-
X fact(branch11,yes),
X fact('pine desired',yes),
X fact('pine suited',yes),
X fact('desirable seed',yes),
X fact('serotinous cones',yes),
X fact('10/acres adequate',no),
X add_fact(silvaculture,clearcut),
X recommend('The best silvaculture method to use is clearcut.').
Xfact(branch17,yes) :-
X fact(branch11,yes),
X fact('pine desired',yes),
X fact('pine suited',yes),
X fact('desirable seed',yes),
X fact('serotinous cones',no),
X fact('two harvests wanted',yes),
X fact('two harvests possible',yes),
X add_fact(silvaculture,shelterwood),
X recommend('The best silvaculture method to use is the shlterwood method.').
Xfact(branch17,yes) :-
X fact(branch11,yes),
X fact('pine desired',yes),
X fact('pine suited',yes),
X fact('desirable seed',yes),
X fact('serotinous cones',no),
X fact('two harvests wanted',yes),
X fact('two harvests possible',no),
X add_fact(silvaculture,clearcut),
X recommend('The best silvaculture method to use is clearcut.').
Xfact(branch17,yes) :-
X fact(branch11,yes),
X fact('pine desired',yes),
X fact('pine suited',yes),
X fact('desirable seed',yes),
X fact('serotinous cones',no),
X fact('two harvests wanted',no),
X add_fact(silvaculture,clearcut),
X recommend('The best silvaculture method to use is clearcut.').
Xfact(branch17,yes) :-
X fact(branch11,yes),
X fact('pine desired',yes),
X fact('pine suited',yes),
X fact('desirable seed',no),
X add_fact(silvaculture,clearcut),
X recommend('The best silvaculture method to use is clearcut.').
Xrecommendation(convert) :-
X fact(branch11,yes),
X fact('pine desired',yes),
X fact('pine suited',no),
X recommend('You should convert the area to some more desirable kind of tree.').
Xrecommendation(convert) :-
X fact(branch11,yes),
X fact('pine desired',no),
X recommend('You should convert the area to some more desirable kind of tree.').
Xfact(branch18,yes) :-
fact(branch17,yes),
X fact('adequate seedbed',yes).
Xfact(branch18,yes) :-
X fact(branch17,yes),
X fact('adequate seedbed',no),
X recommend('The site should be prepared before planting.').
Xrecommendation('natural seeding') :-
X fact(branch18,yes),
X fact(silvaculture,shelterwood),
X recommend('The natural seeding technique should be used.').
Xrecommendation(plant) :-
X fact(branch18,yes),
X fact(silvaculture,clearcut),
X fact('improved stock',yes),
X recommend('Since there is better stock available, you can plant using that stock.').
Xrecommendation('scatter cones') :-
X fact(branch18,yes),
X fact(silvaculture,clearcut),
X fact('improved stock',no),
X fact('good cone supply',yes),
X recommend('You should scatter the serotinous cones over the area.').
Xrecommendation('direct seed') :-
X fact(branch18,yes),
X fact(silvaculture,clearcut),
X fact('improved stock',no),
X fact('good cone supply',no),
X recommend('You should directly seed the area.').
X
X/* These routines add new facts to the internal knowledge base - kb */
X
Xfact(X,Y) :- kb(X,Y),! .
Xfact(X,Y) :- not(kb(X,Anything)),
X question(X,Answer),
X assertz(kb(X,Answer)),
X Y = Answer.
X
Xadd_fact(X,Y) :- kb(X,Y),!.
Xadd_fact(X,Y) :- assertz(kb(X,Y)).
X
Xrecommend(X) :- add_fact(advice,X).
X
X/* Questions to ask the user */
X
Xquestion('stocking good',Ans) :-
X print('Is the stocking of the jack pine stand currently'),nl,
X print('at least minimum ? '),nl,nl,
X print('If you are unsure of how to determine stocking,'),nl,
X print('see page 4 in the Managers Handbook for Jack Pine'),
X nl,
X ask('',Ans,[ yes , no ]).
Xquestion('avg < 5',Ans) :-
X ask('Is the average diameter of the trees less than 5 inches ?',
X Ans,[yes,no]).
Xquestion('2000+ per acre',Ans) :-
X ask('Are there 2000 or more trees per acre ?',Ans,[yes,no]).
question(age,Ans) :-
X ask('Is the age of the stand mature or immature ?',
X Ans,[mature,immature]).
Xquestion('site index > 60',Ans) :-
X ask('Is the site index greater than 60 ?',Ans,[yes,no]).
Xquestion('product size',Ans) :-
X ask('Do you want to manage the timber for large or small products ?',
X Ans,[large,small]).
Xquestion('120+ basal area',Ans) :-
X ask('Is the basal area per acre at least 120 square feet ?',
X Ans,[yes,no]).
Xquestion('other resources',Ans) :-
X ask('Do you want to maintain this condition to support other resources?',
X Ans,[yes,no]).
Xquestion('severe competition',Ans) :-
X ask('Is there severe overstory competition ?',Ans,[yes,no]).
Xquestion('high risk',Ans) :-
X ask('Is there a high risk of loss or injury ?',Ans,[yes,no]).
Xquestion('pine desired',Ans) :-
X ask('Do you want to keep jack pine in this area ?',Ans,[yes,no]).
Xquestion('pine suited',Ans) :-
X ask('Is jack pine well suited to this site ?',Ans,[yes,no]).
Xquestion('desirable seed',Ans) :-
X ask('Is there a desirable jack pine seed source on the area ?',
X Ans,[yes,no]).
Xquestion('serotinous cones',Ans) :-
X ask('Do the trees on the site have serotinous cones ?',Ans,[yes,no]).
Xquestion('10/acres adequate',Ans) :-
X ask('Are 10 trees per acre adequate to seed the area ?',Ans,[yes,no]).
Xquestion('burning planned',Ans) :-
X ask('Has a prescribed burning been planned ?',Ans,[yes,no]).
Xquestion('two harvests wanted',Ans) :-
X ask('Do you want two commercial harvests on this area ?',Ans,[yes,no]).
Xquestion('two harvests possible',Ans) :-
X ask('Is it possible to get two harvests from this area ?',Ans,[yes,no]).
Xquestion('adequate seedbed',Ans) :-
X ask('Is there an adequate seedbed for planting ?',Ans,[yes,no]).
Xquestion('improved stock',Ans) :-
X ask('Is there an improved planting stock available ?',Ans,[yes,no]).
Xquestion('good cone supply',Ans) :-
X ask('Is there a good supply of serotinous cones in the area ?',
X Ans,[yes,no]).
X
X/* Utility Routines - to be useful, we should add some routines to allow
X the user to ask "How" and "Why" */
X
Xdisplay_kb :- kb(X,Y),
X print(X,' is ',Y),
X nl,
X fail.
Xdisplay_kb.
X
X
Xprint_advice :-
X nl,nl,
print('Based upon your responses, the following is recommended :'),nl,nl,
X show_advice.
Xshow_advice :-
X kb(advice,X),
X print(X),
X nl,
X fail.
Xshow_advice :-
X nl,print('To see the complete set of derived facts,'),
X print('type "display_kb."').
X
X
Xclear_kb :- retract(kb(_,_)),
X fail .
Xclear_kb.
X
Xmember(X,[X|_]).
Xmember(X,[_|Y]) :- member(X,Y).
X
Xask(Ques,Ans,LegalResponses) :-
X nl,print(Ques,' '),
X read(Ans),
X member(Ans,LegalResponses),!.
Xask(Ques,Ans,LegalResponses) :-
X nl,nl,nl,
X print('Please respond with : ',LegalResponses),nl,nl,
X ask(Ques,Ans,LegalResponses).
X
X
X
X
X
X
X
X Listings and Figures
X printed in AI EXPERT magazine
X
X
X1. Jack pine stand with minimum or higher stocking .................. 2
X1. Jack pine stand with less than minimum stocking .................. 10
X
X 2. Average tree diameter less than 5 inches ..................... 3
X 2. Average tree diameter 5 inches or more ....................... 4
X
X3. 2,000 or more trees per acre ..................WEED OR CLEAN ..... 8
X3. Less than 2,000 trees per acre ................................... 8
X
X 4. Stand is mature .............................................. 11
X 4. Stand is not mature .......................................... 5
X
XFigure 1 - Key for forest management taken from USDA Forest Service
X Handbook
X
X
X
X |-- yes ===> weed or clean
X | and do # 8
X |-- yes --- 2000+ per acre-|
X | |-- no ===> do # 8
X |-- yes -- diameter-|
X | < 5 in. | |-- mature ===> do # 11
Xminimum | |-- no -- age-|
Xstocking-| |-- young ===> do # 5
X |
X |
echo shar: "a missing newline was added to 'AIAPP.JAN'"
echo shar: "18 control characters may be missing from 'AIAPP.JAN'"
SHAR_EOF
if test 29884 -ne "`wc -c < 'AIAPP.JAN'`"
then
echo shar: "error transmitting 'AIAPP.JAN'" '(should have been 29884 characters)'
fi
fi
echo shar: "extracting 'CONTNT.JAN'" '(2351 characters)'
if test -f 'CONTNT.JAN'
then
echo shar: "will not over-write existing file 'CONTNT.JAN'"
else
sed 's/^ X//' << \SHAR_EOF > 'CONTNT.JAN'
X
X Contents -- AI EXPERT
X January 1987
X
X
XARTICLES
X--------
X
XPlanning with TWEAK
Xby Jonathan Amsterdam
X
XLike all exploratory work in the sciences, AI research proceeds
Xin cycles of 'scruffy' exploration and 'neat' consolidation.
XAfter years of exploration into different planning algorithm
Xdesign strategies, M.I.T.'s David Chapman may have created a new
Xera in planning research with his neat summary of more than a
Xdecade of scruffy work on an algorithm called TWEAK.
X
X
XRete Match Algorithm
Xby Charles L. Forgy and Susan Shepard
X
XThe Rete Match algorithm is a fast method for comparing a set of
Xpatterns to a set of objects to determine all possible matches.
XIt may be the most efficient algorithm for performing the match
Xoperation on single processor. Developed by Charles L. Forgy in
X1974, it has been implemented in several languages in both
Xresearch and commercial grade systems.
X
X
XImperative Pattern Matching in OPS5
Xby Dan Neiman
X
XSurely the Rete Match algorithm is an efficient data structure
Xfor implementing production systems. But what else can it be
Xused for? Let's look at the OPS5 language as a case study of
Xthe Rete net as an experimental tool kit. Then we'll present a
Xtechnique that will show the programmer how to use Rete Match as
Xa general purpose pattern matching tool.
X
X
XPerceptrons and Neural Nets
Xby Peter Reece
X
XThere are at least ten billion neurons handling over one million
Xinput messages per second in the human brain. With many of the
Xearlier hardware and software obstacles now overcome, let's look
Xback to one of the most successful pattern classification
Xcomputers---the Perceptron---and show how you can implement a
Xsimple Perceptron on your home computer.
X
X
XDEPARTMENTS
X-----------
X
XBrain Waves
X"AI for Competitive Advantage"
Xby Eugene Wang, Gold Hill Computers
X
XAI INSIDER
X
XEXPERT'S TOOLBOX
X"Using Smalltalk to Implement Frames"
Xby Marc Rettig
X
XAI APPRENTICE
X"Creating Expert Systems from Examples"
Xby Beverly and Bill Thompson
X
XIN PRACTICE
X"Air Traffic Control: A Challenge for AI"
Xby Nicholas Findler
X
XHARDWARE REVIEW
X"A LISP Machine Profile: Symbolics 3650"
Xby Douglas Schuler, et. al.
X
XSOFTWARE REVIEW
X"Expertelligence's PROLOG for the Mac:
XExperPROLOG II"
X
X
echo shar: "a missing newline was added to 'CONTNT.JAN'"
echo shar: "159 control characters may be missing from 'CONTNT.JAN'"
SHAR_EOF
if test 2351 -ne "`wc -c < 'CONTNT.JAN'`"
then
echo shar: "error transmitting 'CONTNT.JAN'" '(should have been 2351 characters)'
fi
fi
echo shar: "extracting 'EXPERT.JAN'" '(7019 characters)'
if test -f 'EXPERT.JAN'
then
echo shar: "will not over-write existing file 'EXPERT.JAN'"
else
sed 's/^ X//' << \SHAR_EOF > 'EXPERT.JAN'
X
X Expert's Toolbox
X January 1987
X "Using Smalltalk to Implement Frames"
X by Marc Rettig
X
X
X
XListing 1
X
XDEFINITION OF CLASS SLOT
X
XDictionary variableSubclass: #Slot
X instanceVariableNames: ''
X classVariableNames: ''
X poolDictionaries: ''
X
XMETHODS FOR CLASS SLOT
X
XsetFacet:facetName with:aValue
X self at:facetName put:aValue
X ^aValue
X
XgetFacet: facetName
X ^self at:facetName ifAbsent:[nil]
X
XsetValue:aValue
X self setFacet:'value' with:aValue
X
XgetValue
X ^self getFacet:'value'
X
X_________________________________________
XDEFINITION OF CLASS FRAME
X
XDictionary variableSubclass: #Frame
X instanceVariableNames: ''
X classVariableNames: ''
X poolDictionaries: ''
X
XMETHODS FOR CLASS FRAME
X
XsetSlot:slotName facet:facetName contents:aValue
X | tempSlot |
X tempSlot := self at:slotName
X ifAbsent:[self at:slotName put: Slot new].
X tempSlot setFacet:facetName with:aValue.
X ^aValue
X
XgetSlot:slotName facet:facetName
X ^(self includesKey:slotName)
X ifTrue: [(self at:slotName) getFacet:facetName]
X ifFalse:[nil]
X
XsetSlot:slotName value:aValue
X ^self setSlot:slotName facet:'value' contents:aValue
XgetSlotValue:slotName
X "Get the value facet of a slot. If no such slot, look up the AKO
X inheritance chain. It that's no good, run a demon to get the value."
X | temp |
X ((temp := self getSlot:slotName) isNil)
X ifTrue: [((temp := self lookUpAkoChain:slotName) isNil)
X ifTrue: [^self runDemonForValue:slotName]
X ifFalse:[^temp getValue]]
X ifFalse:[(temp includesKey:'value')
X ifTrue: [^temp getValue]]
X ifFalse:[^self runDemonForValue:slotName]]
X
XgetSlot:slotName
X ^self at:slotName ifAbsent:[nil]
X
XsetSlot:slotName with:aSlot
X ^self at:slotName put:aSlot
X
XlookUpAkoChain:slotName
X "Look up the inheritance chain for a slot with the name in slotName.
X If you find it, return the Slot."
X ^(self includesKey:'AKO')
X ifTrue: [((self isAKO) includesKey:slotName)
X ifTrue: [^(self isAKO) getSlot:slotName]
X ifFalse:[^(self isAKO) lookUpAkoChain:slotName]]
X ifFalse:[nil]
X
XisAKO
X ^self getSlot:'AKO' facet:'value'
X
XisAKO:aFrame
X self setSlot:'AKO' value:aFrame
X
X____________________________________
XSOME SAMPLE METHODS FOR DEMONS
X
XaddDemon:aBlock slot:slotName type:demonType
X (#('ifNeeded' 'ifAdded' 'ifRemoved') includes:demonType)
X ifTrue: [self setSlot:slotName facet:demonType with:aBlock]
X ifFalse:[self error:'Invalid Demon Type']
X
XrunDemonForValue:slotName
X | aBlock |
X aBlock := self getSlot:slotName facet:'ifNeeded'.
X (aBlock isNil)
X ifTrue: [^nil]
X ifFalse:[^self setSlot:slotName value:(aBlock value)]
X
X
X
XListing 2
X
XA SAMPLE HIERARCHY OF FRAMES, SHOWING USE OF DEMONS
X
| mammal dog firstDog askDemon |
Xmammal := Frame new.
Xmammal setSlot:'hide' value:'hairy'.
Xmammal setSlot:'blood' value:'warm'.
X
Xdog := Frame new.
Xdog isAKO:mammal.
Xdog setSlot 'numberOfLegs' value:4.
X
X" Here is a simple if-needed demon, which will ask the
X user for a value,while suggesting a default value."
XaskDemon := [Prompter prompt:'What is this doggie''s name?
X default:'Phydeaux'].
X
XfirstDog := Frame new.
XfirstDog addDemon:askDemon slot:'name' type:'ifNeeded'.
XfirstDog isAKO:dog.
XfirstDog setSlot:'color' value:'brown'.
X
X"This message would cause the demon to be fired off..."
Xfido getSlotValue:'name'
X
X
XFRAME.CLS
X
XDictionary variableSubclass: #Frame
X instanceVariableNames: ''
X classVariableNames: ''
X poolDictionaries: '' !
X
X!Frame class methods ! !
X
X
X!Frame methods !
X
XaddDemon:aBlock slot:slotName type:demonType
X (#('ifNeeded' 'ifAdded' 'ifRemoved') includes:demonType)
X ifTrue: [self setSlot:slotName facet:demonType with:aBlock]
X ifFalse:[self error:'Invalid Demon Type']!
X
XgetSlot:slotName
X "return the slot object corresponding to slotName."
X
X ^self at: slotName ifAbsent: [nil]!
X
XgetSlot: slotName facet: facetName
X
X ^(self includesKey: slotName)
X ifTrue: [(self at:slotName) getFacet:facetName]
X ifFalse: [nil]!
X
XgetSlotValue:slotName
X "get the value facet of a slot. If no such slot, look up AKO chain.
X If that's no good, run a demon to get the value."
X
X | temp |
X ((temp := self getSlot: slotName) isNil)
X ifTrue: [((temp := self lookUpAkoChain: slotName) isNil)
X ifTrue: [^self runDemonForValue:slotName]
X ifFalse:[^temp getValue]]
X ifFalse:[(temp includesKey: 'value')
X ifTrue: [^temp getValue]
X ifFalse:[^self runDemonForValue:slotName]]!
X
XisAKO
X ^self getSlot: 'AKO' facet:'value'!
X
XisAKO: aFrame
X "set the AKO slot of a frame"
X
X self setSlot:'AKO' value:aFrame!
X
XlookUpAkoChain: slotName
X "Look up the inheritance chain for a slot with the name in slotName.
X If you find it, return the Slot"
X
X ^(self includesKey: 'AKO')
X ifTrue:[((self isAKO) includesKey:slotName)
X ifTrue: [^(self isAKO) getSlot: slotName]
X ifFalse:[^(self isAKO) lookUpAkoChain: slotName]]
X ifFalse:[nil]!
X
XremoveSlot: slotName
X ^self removeKey:slotName ifAbsent:[nil]!
X
XrunDemonForValue: slotName
X
X | aBlock |
X aBlock := self getSlot: slotName facet: 'ifNeeded'.
X (aBlock isNil)
X ifTrue: [^nil]
X ifFalse:[^self setSlot:slotName value:(aBlock value)]!
X
XsetSlot: slotName facet: facetName with: value
X
X | tempSlot |
X tempSlot := self at:slotName
X ifAbsent: [self at:slotName put: Slot new].
X tempSlot setFacet: facetName with: value.
X ^value!
X
XsetSlot:slotName value:aValue
X "set the value facet of a slot"
X
X ^self setSlot:slotName facet:'value' with:aValue.!
X
XsetSlot:slotName with: aSlot
X "associate the slot aSlot with the name slotName. "
X
X ^self at: slotName put: aSlot! !
X
X
XFRMTRM.TXT
X
X| mammal dog fido s askDemon t |
X" Examples of frame and slot classes in use.
X Select and DOIT."
X
Xmammal := Frame new.
Xmammal setSlot: 'hide' value: 'hairy'.
Xmammal setSlot: 'bloodType' value: 'warm'.
X
Xdog := Frame new.
Xdog isAKO: mammal.
Xdog setSlot: 'numberLegs' value: 4.
X
XaskDemon := [Prompter prompt:'What is this dog''s name?' default: 'Bruno'].
Xdog addDemon:askDemon slot:'name' type:'ifNeeded'.
X
Xfido := Frame new.
Xfido addDemon:askDemon slot:'name' type:'ifNeeded'.
Xfido isAKO:dog.
Xfido setSlot:'color' value:'brown'.
X
X" Let's see the demon fire "
Xfido getSlotValue:'name'.
X
X
XSLOT.CLS
X
XDictionary variableSubclass: #Slot
X instanceVariableNames: ''
X classVariableNames: ''
X poolDictionaries: '' !
X
X!Slot class methods ! !
X
X
X!Slot methods !
X
XgetFacet: facetName
X ^self at: facetName ifAbsent: [nil]!
X
XgetValue
X ^self getFacet: 'value'!
X
XremoveFacet: facetName
X ^self removeKey:facetName ifAbsent:[nil]!
X
XsetFacet: facetName with: aValue
X
X self at: facetName put: aValue.
X ^aValue!
X
XsetValue: aValue
X self setFacet: 'value' with: aValue! !
X a
echo shar: "a missing newline was added to 'EXPERT.JAN'"
echo shar: "55 control characters may be missing from 'EXPERT.JAN'"
SHAR_EOF
if test 7019 -ne "`wc -c < 'EXPERT.JAN'`"
then
echo shar: "error transmitting 'EXPERT.JAN'" '(should have been 7019 characters)'
fi
fi
echo shar: "extracting 'FILES.JAN'" '(837 characters)'
if test -f 'FILES.JAN'
then
echo shar: "will not over-write existing file 'FILES.JAN'"
else
sed 's/^ X//' << \SHAR_EOF > 'FILES.JAN'
X
X
X Articles and Departments that have
X Additional On-Line Files
X
X AI EXPERT
X January 1987
X (Note: Contents page is in file CONTNT.JAN)
X
X
X
X
XARTICLES RELEVANT FILES
X-------- --------------
X
XJanuary Table of Contents CONTNT.JAN
X
XAdding Rete Net to Your OPS5 Toolbox OPSNET.JAN
Xby Dan Neiman
X
XPerceptrons & Neural Nets PERCEP.JAN
Xby Peter Reece
X
X
XDEPARTMENTS
X
XExpert's Toolbox EXPERT.JAN
X"Using Smalltalk to Implement Frames"
Xby Marc Rettig
X
XAI Apprentice AIAPP.JAN
X"Creating Expert Systems frm Examples"
Xby Beverly and Bill Thompson
X
SHAR_EOF
if test 837 -ne "`wc -c < 'FILES.JAN'`"
then
echo shar: "error transmitting 'FILES.JAN'" '(should have been 837 characters)'
fi
fi
echo shar: "extracting 'OPSNET.JAN'" '(359936 characters)'
if test -f 'OPSNET.JAN'
then
echo shar: "will not over-write existing file 'OPSNET.JAN'"
else
sed 's/^ X//' << \SHAR_EOF > 'OPSNET.JAN'
X
X
X Adding the Rete Net to Your OPS5 Toolbox
X (Supplemental files arranged by filename headings)
X January 1987 AI EXPERT
X by Dan Neiman
X
X
X
XEditor's Note:
X
XAdditional notes and clarifications for Imperative Pattern Match code,
Xas described in January '87 issue of AI/Expert.
X
XThe code described in AI/Expert is still evolving (i.e. the more I use it, the more
Xfeatures I add), and there was not sufficient space to give complete instructions in
Xthe magazine, so the following notes should be used as a supplement to the
Xarticle.
X
XTo use the Rete net modifications, load the code into an existing Common Lisp OPS5
Ximage. Then use the pmatch and map-pmatch functions as described in the article.
X
X
XIt was probably not made clear in the article, but both pmatch and map-pmatch
Xreturn the values of the last expression evaluated in the righthand side. So,
Xfor example, to get the names of all employees making 30K a year, you might use the
Xcode:
X?(map-pmatch (employees ^name <emp> ^salary > 30000)
X -->
X ?<emp> )
X
XThe RHS of the above function just evaluates and returns the binding of <emp>.
XBecause the function used was map-pmatch, a list of *all* employees satisfying the
Xgiven constraints is returned.
X
XThe syntax of the pmatch and map-pmatch commands has been modified slightly since
Xthe article went to press. The method described for passing Lisp variables to a
Xpattern match function proved to be inexpressibly awkward for lexically bound Lisps
X(the system was originally written in Franz). The following modification makes it
Xconsiderably easier to pass arguments to the pattern match routines.
X
XBecause the pattern match is compiled, the only way to interactively match a particular
Xvalue is to write that value into working memory, and include that working memory element
Xin the pattern match. This is fairly awkward to do by hand, so I've incorporated a macro
Xinto the pmatch and map-pmatch commands which do it automagically. The arguments are passed
Xby following the pmatch function with an argument list. The argument list is distinguished
Xfrom a pattern by the "args" keyword. The syntax is:
X
X(pmatch (args arg1 arg2 ... argN)
X (condition element 1)
X (condition element 2)
X -->
X RHS)
X
XAfter macro expansion, the result is effectively
X (let ((tt (make ipm$data arg1 arg2 ... argN)))
X (query1 (ipm$data <arg1> <arg2> <arg3>)
X (condition element 1)
X (condition element 2)
X : : :
X -->
X RHS)
X (oremove tt) )
X
XNote that the working memory element is added and deleted automatically.
X
XAs an example, the code to locate all children of a couple might look like this
X(defun children(mother father)
X ?(map-pmatch (args mother father)
X (mother ^name <mother> ^child <child>)
X (father ^name <father> ^child <child>)
X -->
X (make parents ^name <child> ^father <father> ^mother <mother>)
X ?<child>)
X
Xand given the working memory:
X(mother ^name ann ^child bob)
X(father ^name fred ^child bob)
X(mother ^name sue ^child alex)
X(father ^name fred ^child john)
X(mother ^name ann ^child john)
X(father ^name fred ^child cheryl)
X
X(children 'ann 'fred) would return (bob john)
X
Xand create the working memory elements
X
X(parents ^name bob ^father fred ^mother ann)
X(parents ^name john ^father fred ^mother ann)
X
XDebugging code: As is the case with OPS5 productions, if you recompile a pmatch
Xor map-pmatch function, you must remove working memory and replace it. A pattern match
Xwill only work on data which has been added after compilation. This does tend to
Xmake debugging tedious.
X
XEverytime a pmatch operation is recompiled, it generates a new body bound to a variable of
Xthe form queryN. Because queries are not explictly named, it's difficult to automatically
Xexcise them. So the net will tend to fill with superfluous nodes during debugging.
XThe function exquery will excise all existing queries. Executing the sequence,
X(oremove *)
X(exquery)
X(i-g-v)
X
Xwill remove all working memory and queries and reset all global variables.
X
XIf a pmatch or map-pmatch function blows up while evaluating its RHS, reset the
Xglobal variable *in-rhs* to nil before proceeding.
X
XQuestions about this code can be directed to:
XDan Neiman
XCompuServe 72277,2604
XCSNET dann@UMASS-CS.csnet
X
Xor c/o COINS Dept.
X Lederle Graduate Research Center
X University of Massachusetts
X Amherst, MA 01003
X
X
XIndex to software:
X
XCLSUP.LSP : Common Lisp support functions to define some canonical
X functions missing in Common Lisp.
X
XOPSMODS.L : The OPS5 modifications described in the article.
X
XCOMMON.OPS : OPS5 for Common Lisp
XTI.OPS : OPS5 for TI Explorers
XFRANZ.OPS : OPS5 for Franz Lisp
X
XMONK.OPS : Test file for OPS5
XPRTOWER.OPS : Test file for OPS5
X
X
XNEWOPS.L
X
X;OPS5 modifications for Common Lisp
X; by: Dan Neiman
X; Original idea conceived at ITT ATC May, 1986
X; Converted to Common Lisp and expanded at COINS Dept., UMASS Fall 1986
X
X;Copyright notice: Much of this code is modified or original OPS5 code which is
X;copyrighted by C. Lanny Forgy of CMU, and is used with his permission. The rest is
X;Copyright (c) Daniel Neiman, COINS Dept. UMass. Permission is given to use this
X;code freely for personal, educational, or research applications. It is not to be
X;sold, or incorporated into a for-profit product without permission of the author.
X;The purpose of this code is to illustrate alternative uses of the Rete net and
X;alternative control structures in OPS5. No guarantees are made about its fitness
X;any particular application, and no claim is made about the presence or absence of
X;bugs.
X;Version of 12/12/86
X
X;This file contains the necessary OPS5 modifications to perform
X;the RHS pattern matching/control function described in the
X;accompanying January '87 AI/Expert article. The code is a supplement to OPS5 and is
X;intended to be loaded into a Common Lisp OPS5 image.
X
X;Note: The idea behind this modification is to add memory to the &p node and create
X;functions to interrogate that memory at will. Sort of an elegant idea. But, because
X;it has to be patched into an implementation which was not designed to do so, there's a
X;lot of fairly nasty looking code here. Take heart, most of it is just slightly modified
X;ops5 code and can be pretty much ignored.
X
X;This variable is used to determine if we encountered a pmatch
X;or map-pmatch in top-level lisp code or while compiling an
X;OPS5 production.
X
X(proclaim '(special *compiling-rhs* *qnames* *cmp-p-context-stack*
X *system-state-stack* *NMATCHES* *ipm-data-stack*))
X(setq *qnames* nil)
X(setq *system-state-stack* nil)
X(setq *cmp-p-context-stack* nil)
X(setq *compiling-rhs* nil)
X(setq *ipm-data-stack* nil)
X
X;Read macro for variable evaluation on "RHS" of pattern match
X;All &whatever macros on the righthand side must be preceded by
X;a ?. This will expand to ($varbind '&whatever)
X;To avoid having a plethora of read macros, ? will be double-duty.
X;If ? precedes a ?(pmatch ....), then the expression is evaluated
X;and the appropriate match stuff is placed in the rete net. The
;code is replaced by (query queryN pattern-body).
X
X;Read macro ? executes the following function.
X(defun $$ipm$$dofunc$$(strm chr)
X (let ((inp (read strm t nil t)))
X (cond ((atom inp)
X (if (eq '#\< (char (string inp) 0)) ;is it an OPS variable?
X `($varbind ',inp)
X (intern (concatenate 'string "?" (princ-to-string inp)))))
X ((member (car inp) '(map-pmatch pmatch) :test #'eq)
X (eval inp))
X (t
X inp))))
X
X
X;make ? a read macro
X(set-macro-character #\? #'$$ipm$$dofunc$$ t)
X
X(defun &query (rating name var-dope ce-var-dope rhs frhs)
X (prog (fp dp)
X (cond (*sendtocall*
X (setq fp *flag-part*)
X (setq dp *data-part*))
X (t
X (setq fp *alpha-flag-part*)
X (setq dp *alpha-data-part*)))
X (and (member fp '(nil old))
X (ipm-removepm name dp))
X (and fp (ipm-insertpm name dp))))
X
X
X; each conflict set element is a list of the following form:
--
---------------
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-9400turner@imagen.UUCP (D'arc Angel) (01/19/87)
X; ((p-name . data-part) (sorted wm-recency) special-case-number)
X
X;I'm storing the results of the pattern matches on a property list, pmatches.
X
X;modified OPS5 removecs
X;remove results of the pattern match
X
X(defun ipm-removepm (name cr-data)
X (prog (inst cs pmtchs)
X(setq pmtchs (setq cs (get name 'pmatches)))
X l(cond ((null cs)
X (return nil)))
X(setq inst (car cs))
X(setq cs (cdr cs))
X(and (not (top-levels-eq inst cr-data)) (go l))
X(putprop name (remove inst pmtchs)
X 'pmatches)
X))
X
X;modified OPS5 insertcs
X;store the results of the pattern match
X;Stored as (data ) rather than original conflict set format
X;of ((name . data) (order tags) rating)
X(defun ipm-insertpm (name data)
X (let ((pmtch (get name 'pmatches)))
X (setq pmtch (get name 'pmatches))
X (and (atom pmtch) (setq pmtch nil))
X (setq pmtch (cons data pmtch))
X (putprop name pmtch 'pmatches)
X pmtch
X ))
X
X;PMATCH is the RHS/LISP equivalent of the (p rule) macro. When used from Lisp,
X;it should always be preceded by the ? read macro, so as to force evaluation
X;at read time. Otherwise, the Rete net won't be set up correctly.
X
X(defmacro pmatch(&rest z)
X `(let ((pname (newsym query))
X (level (newsym level)))
X (finish-literalize)
X (princ '*)
X (cond ((and (listp (car ',z)) (eq (caar ',z) 'args))
X (ipm-compile-production pname (add-data-to-prod pname ',z ))
X `(let ((tt (make-ipm-data ',pname ,@(cdar ',z) ))
X (ans (query ',pname)))
X(restore-ipm-data tt)
X ans))
X (t
X (ipm-compile-production pname ',z)
X `(query ',pname)))))
X
X(defun restore-ipm-data(current)
X (let ((inrhsflg *in-rhs*)
X (old (pop *ipm-data-stack*)))
X (setq *in-rhs* nil)
X (eval (list 'oremove current))
X (setq *in-rhs* inrhsflg)
X (if old
X (add-to-wm (car old) (cdr old)))))
X
X;Note, the only way to pass input to the pattern matcher is to create a
X;working memory element containing that input. The following utility functions
X;automagically create the ipm$data working memory element and modify the
X;production to use it.
X
X;MAKE-DATA: Make data takes a list of values and a unique level specifier
X;and creates a working memory element of the form (ipm$data val1 val2 val3 .. )
X;Saves old ipm$data elements on stack so that no interference results.
X(defun make-ipm-data(&rest arglst)
X (let ((inrhsflg *in-rhs*)
X (old (car (get 'ipm$data 'wmpart*))))
X (if old (push old *ipm-data-stack*))
X (setq *in-rhs* nil)
X (eval (list 'oremove (cdr old))) ;needs in-rhs to be nil
X (setq *in-rhs* inrhsflg)
X ($reset)
X ($change 'ipm$data)
(mapc #'(lambda(tab val)
X ($tab tab)
X ($change val))
X '(a b c d e f g h i j k l) (cdr arglst))
X ($tab 'for) ;target data for particular query
X ($change (car arglst))
X ($assert)))
X
X;Modify the production so that it accesses the data passed by the ipm$data wme
X(defun add-data-to-prod(pname prod)
X (let ((args (cdar prod))
X (body (cdr prod)))
X (cons
X `(ipm$data ,@(mapcan #'(lambda(slot arg) (list '^ slot (concat '\< arg '\> )))
X '(a b c d e f g h i j k l) args)
X ^for ,pname)
X body)))
X
X
X;Finish-literalize: modified to define special wme type ipm$data which is used to
X;transfer lisp arguments to working memory.
X(defun finish-literalize nil
X (cond ((not (null *class-list*))
X (cond ((not (member 'ipm$data *class-list*))
X (literalize ipm$data a b c d e f g h i j k l for)))
X (mapc (function note-user-assigns) *class-list*)
X (mapc (function assign-scalars) *class-list*)
X (mapc (function assign-vectors) *class-list*)
X (mapc (function put-ppdat) *class-list*)
X (mapc (function erase-literal-info) *class-list*)
X (setq *class-list* nil)
X (setq *buckets* nil))))
X
X
X
X;Map the RHS across all matching data.
X(defmacro map-pmatch(&rest z)
X `(let ((pname (newsym query))
X (level (newsym level)))
X (finish-literalize)
X (princ '*)
X (cond ((and (listp (car ',z)) (eq (caar ',z) 'args))
X (ipm-compile-production pname (add-data-to-prod pname ',z ))
X `(let ((tt (make-ipm-data ',pname ,@(cdar ',z) ))
X (ans (map-query ',pname)))
X(restore-ipm-data tt)
Xans))
X (t
X (ipm-compile-production pname ',z)
X `(map-query ',pname)))))
X
X
X(defun ipm-compile-production (name matrix)
X (prog (erm)
X (setq *p-name* name)
(cond (*compiling-rhs*
X (setq erm (catch (ipm-cmp-p-recursive name matrix) '!error!)))
X (t
X (setq erm (catch (ipm-cmp-p name matrix) '!error!))))
X; following line is modified to save production name on *qnames*
X (pushnew name *qnames*)
X(return erm)))
X
X
X;save globals *feature-count *ce-count* *vars* *ce-vars* *rhs-bound-vars*
X;*rhs-bound-ce-vars* *last-branch* on a push-down stack.
X
X;Push global variables takes a stack name, and a list of global variables, creates a
X;list of lists of the form ((varname value) (varname value) ... ) and pushes it onto
X;the indicated stack.
X
X(defun push-global-variables(stack &rest vars)
X (push
X (mapcar #'(lambda(var)
X (cons var (eval var))) ;copy may not be needed, but better safe....
X vars)
X (symbol-value stack)))
X
X;Pop global variables takes a stack name, pops most recent entry off the stack,
X;and resets the values of the variables.
X(defun pop-global-variables(stack)
X (mapcar #'(lambda(varbinding)
X (set (car varbinding) (cdr varbinding)))
X (pop stack)) )
X
X
X;This version of cmp-p is used when compiling patterns on the
X;righthand side in which we want variable bindings consistent
X;with variable bindings on the LHS. Effectively, the RHS
X;pattern is just treated as a continuation of the LHS
X;pattern, except, of course, that the results of the RHS
X;pattern match will not affect the firing of the production.
X(defun ipm-cmp-p-recursive (name matrix)
X (prog (m bakptrs srhs frhs)
X (push-global-variables '*cmp-p-context-stack* '*matrix*
X '*feature-count* '*ce-count*
X '*vars* '*ce-vars*
X '*rhs-bound-vars* '*rhs-bound-ce-vars*
X '*last-branch* '*last-node*)
X (prepare-lex matrix)
X(setq *rhs-bound-vars* nil)
X(setq *rhs-bound-ce-vars* nil)
X (setq m (rest-of-p))
X l1 (and (end-of-p) (\%error '|no '-->' in production| m))
X (cmp-prin)
X (setq bakptrs (cons *last-branch* bakptrs))
X (or (eq '--> (peek-lex)) (go l1))
X (lex)
X(setq srhs (rest-of-p)) ; get righthand side
X(if (setq frhs (cdr (memq '<-- srhs)))
(setq srhs (remove-frhs srhs)))
X(ipm-check-rhs srhs)
X;note, we change the structure of the &query node to have a tail
X;component. This is the action to take on a failed pattern match
X (link-new-node (list '&query
X *feature-count*
X name
X (encode-dope)
X (encode-ce-dope)
X (cons 'progn srhs)
X (cons 'progn frhs)))
X (putprop name (cdr (nreverse bakptrs)) 'backpointers)
X(putprop name matrix 'production)
X (putprop name *last-node* 'topnode)
X(pop-global-variables *cmp-p-context-stack*)
X))
X
X;Extract failed pattern match rhs actions from production.
X(defun remove-frhs(rhs)
X (do ((lis nil (append lis (list inp)))
X(inp (car rhs) (car rhs)))
X ((eq inp '<--)
X(return lis))
X (setq rhs (cdr rhs))
X ))
X
X;;Modified version of OPS5 cmp-p, compiles pattern match and links
X;&query node into Rete net. If pmatch occurs in the righthand side of the rule, then
X;nodes are linked to tree generated by rule's LHS.
X(defun ipm-cmp-p (name matrix)
X (prog (m bakptrs srhs frhs)
X (prepare-lex matrix)
X (excise-p name)
X (setq bakptrs nil)
X (setq *pcount* (1+ *pcount*))
X (setq *feature-count* 0.)
X(setq *ce-count* 0)
X (setq *vars* nil)
X (setq *ce-vars* nil)
X(setq *rhs-bound-vars* nil)
X(setq *rhs-bound-ce-vars* nil)
X (setq *last-branch* nil)
X (setq m (rest-of-p))
X l1 (and (end-of-p) (\%error '|no '-->' in production| m))
X (cmp-prin)
X (setq bakptrs (cons *last-branch* bakptrs))
X (or (eq '--> (peek-lex)) (go l1))
X (lex)
X(setq srhs (rest-of-p)) ; get righthand side
X(if (setq frhs (cdr (memq '<-- srhs)))
X (setq srhs (remove-frhs srhs)))
X(ipm-check-rhs srhs)
X;note, we change the structure of the &query node to have a tail
X;component. This is the action to take on a failed pattern match
X (link-new-node (list '&query
*feature-count*
X name
X (encode-dope)
X (encode-ce-dope)
X (cons 'progn srhs)
X (cons 'progn frhs)))
X(terpri)
X (putprop name (cdr (nreverse bakptrs)) 'backpointers)
X(putprop name matrix 'production)
X (putprop name *last-node* 'topnode)))
X
X;Modified OPS5 code, sets *compiling-rhs* variable.
X(defun check-rhs (rhs)
X (setq *compiling-rhs* t)
X (mapc (function check-action) rhs)
X (setq *compiling-rhs* nil))
X
X
X;rhs part to be evaluated upon pattern match failure
X
X(defun frhs-part (pnode) (car (last pnode)))
X
X;;returns value of last expression in RHS
X(defun query (qname)
X (ipm-eval-query qname (car (get qname 'pmatches))))
X
X;IPM-EVAL-QUERY: Given a pointer to a query and the associated data, this function
X;sets up the appropriate environment to evaluate the RHS of the pattern match.
X;This is a modified eval-rhs from OPS5.
X
X(defun ipm-eval-query (pname data)
X (let ((node (get pname 'topnode))
X (ans nil)
X (saved nil))
X (if (setq saved *in-rhs*) ;in case of recursive call,save system state and
X (save-system-state)) ;set saved flag
X (setq *data-matched* data)
X (setq *p-name* pname)
X (setq *last* nil)
X (setq node (get pname 'topnode))
X (ipm-init-var-mem (var-part node))
X (ipm-init-var-nmatches pname)
X (ipm-init-ce-var-mem (ce-var-part node))
X (setq *in-rhs* t)
X (setq ans
X (if (neq *NMATCHES* 0) ;if match failed, execute failpart, if any
X(eval (rhs-part node))
X(eval (frhs-part node)) ))
X (setq *in-rhs* nil)
X (if saved
X (restore-system-state))
X ans
X))
X
X;map-query is just like query, except that we are performing the
;eval operation for each match. Therefore, some of the initialization
X;must be factored out of ipm-eval-map-query.
X(defun map-query(qname)
X (let* ((node (get qname 'topnode))
X (ans nil)
X (saved nil))
X (if (setq saved *in-rhs*) ;in case of recursive call,save system state and
X (save-system-state)) ;set saved flag
X (setq *p-name* qname)
X (setq *last* nil)
X (setq ans
X (if (> (length (get qname 'pmatches)) 0)
X (mapcar '(lambda(qinstance)
X (ipm-eval-map-query qname qinstance node))
X (get qname 'pmatches))
X (eval (frhs-part node)) ))
X (if saved
X (restore-system-state))
X ans))
X
X(defun ipm-eval-map-query (qname data node)
X (let ((ans))
X (setq *data-matched* data)
X (setq node (get qname 'topnode))
X (ipm-init-var-mem (var-part node))
X (ipm-init-var-nmatches qname)
X (ipm-init-ce-var-mem (ce-var-part node))
X (setq *in-rhs* t)
X (setq ans (eval (rhs-part node)))
X (setq *in-rhs* nil)
X ans
X ))
X
X
X;the variable &nmatches is bound to the number of production
X;matches in each query. Useful for counting applications and
X;deciding if any matches succeeded.
X
X(defun ipm-init-var-nmatches(pname)
X (setq *NMATCHES* (length (get pname 'pmatches)))
X (setq *variable-memory* ;remove previous number of matches
X (remove (assoc '\<NMATCHES\> *variable-memory*) *variable-memory*))
X (setq *variable-memory* ;set up &NMATCHES environ. variable
X (cons (cons '\<NMATCHES\> *NMATCHES*)
X*variable-memory*)))
X
X;More modified OPS5 code. Initializes the variable and ce-variable bindings
X;to be consistent with the results of the pattern match.
X(defun ipm-init-var-mem (vlist)
X (prog (v ind r)
X(or *in-rhs* ;if we're in rhs, then global is already set
X (setq *variable-memory* nil))
X top (and (atom vlist) (return nil))
X (setq v (car vlist))
X (setq ind (cadr vlist))
(setq vlist (cddr vlist))
X (setq r (gelm *data-matched* ind))
X (setq *variable-memory* (cons (cons v r) *variable-memory*))
X (go top)))
X
X(defun ipm-init-ce-var-mem (vlist)
X (prog (v ind r)
X(or *in-rhs* ;if we're in rhs, then global is already set
X (setq *ce-variable-memory* nil))
X top (and (atom vlist) (return nil))
X (setq v (car vlist))
X (setq ind (cadr vlist))
X (setq vlist (cddr vlist))
X (setq r (ce-gelm *data-matched* ind))
X (setq *ce-variable-memory*
X (cons (cons v r) *ce-variable-memory*))
X (go top)))
X
X(defun save-system-state()
X (push-global-variables '*system-state-stack* '*ce-variable-memory* '*data-matched*
X '*variable-memory* '*NMATCHES* '*p-name* '*in-rhs*))
X
X(defun restore-system-state()
X (pop-global-variables *system-state-stack*))
X
X;changed OPS5 code to accept &query
X(defun link-new-node (r)
X (cond ((not (member (car r) '(&query &p &mem &two &and ¬)))
X (setq *feature-count* (1+ *feature-count*))))
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-node* (link-left *last-node* r)))
X
X(defun ipm-check-rhs (rhs)
X (setq *compiling-rhs* t)
X (mapc (function ipm-check-action) rhs)
X (setq *compiling-rhs* nil))
X
X(defun myreplace(x y)
X (rplaca x (car y))
X (rplacd x (cdr y)))
X
X;This check-action is called by pmatch or map-pmatch macros
X(defun ipm-check-action (x)
X (prog (a)
X (cond ((atom x)
X (%warn '|atomic action| x)
X (return nil)))
X (setq a (setq *action-type* (car x)))
X (cond ((eq a 'bind) (check-bind x))
X ((eq a 'query) nil) ;never happens?
X ((eq a 'map-query) nil) ;never happens?
X ;if we come across an unexpanded pmatch, expand and compile it.
X ;replace with result
X ((eq a 'pmatch) (myreplace x (eval x)))
X ((eq a 'map-pmatch) (myreplace x (eval x)))
((eq a 'cbind) (check-cbind x))
X ((eq a 'make) (check-make x))
X ((eq a 'modify) (check-modify x))
X ((eq a 'remove) (check-remove x))
X ((eq a 'write) (check-write x))
X ((eq a 'call) (check-call x))
X ((eq a 'halt) (check-halt x))
X ((eq a 'openfile) (check-openfile x))
X ((eq a 'closefile) (check-closefile x))
X ((eq a 'default) (check-default x))
X ((eq a 'build) (check-build x))
X (t nil) ;in a pmatch rhs, code is not restricted to OPS rhs actions.
X )))
X
X;This check action is just modified so that pmatch or map-pmatch
X;are acceptable right-hand sides.
X(defun check-action (x)
X (prog (a)
X (cond ((atom x)
X (%warn '|atomic action| x)
X (return nil)))
X (setq a (setq *action-type* (car x)))
X (cond ((eq a 'bind) (check-bind x))
X ((eq a 'query) nil) ;never happens
X ((eq a 'map-query) nil) ;never happens
X ;if we come across an unexpanded pmatch, expand and compile it.
X ;replace with result
X ((eq a 'pmatch) (myreplace x (eval x)))
X ((eq a 'map-pmatch) (myreplace x (eval x)))
X ((eq a 'cbind) (check-cbind x))
X ((eq a 'make) (check-make x))
X ((eq a 'modify) (check-modify x))
X ((eq a 'remove) (check-remove x))
X ((eq a 'write) (check-write x))
X ((eq a 'call) (check-call x))
X ((eq a 'halt) (check-halt x))
X ((eq a 'openfile) (check-openfile x))
X ((eq a 'closefile) (check-closefile x))
X ((eq a 'default) (check-default x))
X ((eq a 'build) (check-build x))
X (t (%warn '|undefined rhs action| a)))))
X
X
X;add-to-wm: modified to return timetag number of item added
X(defun add-to-wm (wme override)
X (prog (fa z part timetag port)
X (setq *critical* t)
X (setq *current-wm* (1+ *current-wm*))
X (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
X (setq *action-count* (1+ *action-count*))
X (setq fa (wm-hash wme))
X (or (memq fa *wmpart-list*)
X (setq *wmpart-list* (cons fa *wmpart-list*)))
X (setq part (get fa 'wmpart*))
X (cond (override (setq timetag override))
(t (setq timetag *action-count*)))
X (setq z (cons wme timetag))
X (putprop fa (cons z part) 'wmpart*)
X (record-change '=>wm *action-count* wme)
X (match 'new wme)
X (setq *critical* nil)
X (cond ((and *in-rhs* *wtrace*)
X (setq port (trace-file))
X (terpri port)
X (princ '|=>wm: | port)
X (ppelm wme port)))
X (and *in-rhs* *mtrace* (setq *madeby*
X (cons (cons wme *p-name*) *madeby*)))
X (return timetag)))
X
X(defun &old (&rest a) nil) ;a null function used for deleting node
X
X
X;MAKESYM: Does the same thing as gensym, but allows a symbol to be passed, so
X; the resulting symbol is meaningful.
X(defun makesym(x)
X (prog(numb)
X (and (not (setq numb (get x '$cntr)))
X (setq numb 0))
X (putprop x (add1 numb) '$cntr)
X (return (concat x numb))))
X
X;CONCAT: Make a symbol from a number of symbols
X(defun concat(&rest x)
X (do ((lst x (cdr lst))
X (strng nil))
X ((null lst)
X (intern strng))
X (setq strng (concatenate 'string strng (princ-to-string (car lst))))
X ))
X
X;A general purpose gensym function. Input is
X; [atom], output is [atom]N, where N is a unique integer.
X; ie. (newsym baz) ==> baz1
X; (newsym baz) ==> baz2, etc.
X
X(defmacro newsym(x)
X `(makesym ',x))
X
X
X(defun exquery()
X (mapc #'(lambda(q) (eval `(excise ,q))) *qnames*)
X (setq *qnames* nil))
X
X;The following is a minimal test for the opsmods programs.
X;To use it, uncomment it, and load it. The code should load without
X;blowing up. Complaints about atomic actions in RHS are OK, ignore them.
X;Type
X;(setup)
X;(cs) -- foo and baz should be in the conflict set.
;Type (run 1), the program should print out a list of blocks.
X;(run) should continue until only chartreuse blocks are left.
X;While simple, this code tests for nested use of pattern matches, recursive calls,
X;and use of pmatch in the rhs of OPS productions.
X;(i-g-v)
X;(literalize block a b c)
X
X
X;(p baz
X; { <a> (block ^a <colour> ) }
X; (block ^a <> <colour>)
X; -->
X; (pmatch (block ^a <> <colour> )
X; -->
X; (find-block-colors ?<colour> )
X; (oremove <a> ))
X; (make block ^a chartreuse))
X
X;Test for recursive use of pmatch. (find-block-colors uses map-pmatch and
X;appears in a RHS of another pmatch)
X;(defun rtest(a )
X; ?(pmatch (args a )
X; (block ^a <a> <numb>)
X; -->
X; (find-block-colors 'green)
X; (format t "Block color ~a is ~a~%" ?<a> ?<numb>)))
X
X;(defun find-block-colors (color)
X; ?(map-pmatch (args color)
X; (block ^a <color> <numb>)
X; -->
X; (format t "~%Find-block-colors ~a ~a~%" ?<color> ?<numb>)))
X
X;(defun setup()
X; (setq *in-rhs* nil)
X; (oremove *)
X; (make block ^a green 1)
X; (make block ^a green 2)
X; (make block ^a green 3)
X; (make block ^a green 4)
X; (make block ^a green 5)
X; (make block ^a red 6)
X; (make block ^a red 7)
X; (make block ^a yellow 8)
X; (make block ^a blue 9)
X; )
X
X
XCLSUP.LIS
X
X;Common Lisp Support Functions:
X;These functions are not defined in vanilla Common Lisp, but are used
X;in the OPSMODS.l code and in OPS5.
X
X(defun putprop(name val att)
X (setf (get name att) val))
X
X(defun memq(obj lis)
X (member obj lis :test #'eq))
X
X(defun fix(num)
X (round num))
X
X
X(defun assq(item alist)
X (assoc item alist :test #'eq))
X
X(defun ncons(x) (cons x nil))
X
X(defun neq(x y) (not (eq x y)))
X
X(defun delq(obj list)
X (delete obj list :test #'eq))
X
X(defmacro comment(&optional &rest x) nil) ;comment is a noop
X
X(defun plus(x y)
X (+ x y))
X
X(defun quotient(x y)
X (/ x y))
X
X(defun flatc(x)
X (length (princ-to-string x)))
X
X
X
XCOMMON.OPS
X
X; VPS2 -- Interpreter for OPS5
X;
X; Copyright (C) 1979, 1980, 1981
X; Charles L. Forgy, Pittsburgh, Pennsylvania
X
X
X
X; Users of this interpreter are requested to contact
X
X;
X; Charles Forgy
X; Computer Science Department
X; Carnegie-Mellon University
X; Pittsburgh, PA 15213
X; or
X; Forgy@CMUA
X;
X; so that they can be added to the mailing list for OPS5. The mailing list
X; is needed when new versions of the interpreter or manual are released.
X
X
X
X;;; Definitions
X
X#+ vax (defun putprop(name val att)
X (setf (get name att) val))
X
X
X
X(proclaim '(special *matrix* *feature-count* *pcount* *vars* *cur-vars*
X *curcond* *subnum* *last-node* *last-branch* *first-node*
X *sendtocall* *flag-part* *alpha-flag-part* *data-part*
X *alpha-data-part* *ce-vars* *virtual-cnt* *real-cnt*
X *current-token* *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
X *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
X *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
X *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
X *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
X *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
X *c60* *c61* *c62* *c63* *c64* *record-array* *result-array*
X *max-cs* *total-cs* *limit-cs* *cr-temp* *side*
X *conflict-set* *halt-flag* *phase* *critical*
X *cycle-count* *total-token* *max-token* *refracts*
X *limit-token* *total-wm* *current-wm* *max-wm*
X *action-count* *wmpart-list* *wm* *data-matched* *p-name*
X *variable-memory* *ce-variable-memory*
X *max-index* ; number of right-most field in wm element
X *next-index* *size-result-array* *rest* *build-trace* *last*
X *ptrace* *wtrace* *in-rhs* *recording* *accept-file* *trace-file*
X *mtrace* *madeby* ; used to trace and record makers of elements
X *write-file* *record-index* *max-record-index* *old-wm*
X *record* *filters* *break-flag* *strategy* *remaining-cycles*
X *wm-filter* *rhs-bound-vars* *rhs-bound-ce-vars* *ppline*
X *ce-count* *brkpts* *class-list* *buckets* *action-type*
X *literals* ;stores literal definitions
X *pnames* ;stores production names
X *externals* ;tracks external declarations
X *vector-attributes* ;list of vector-attributes
X ))
X
X;(declare (localf ce-gelm gelm peek-sublex sublex
X; eval-nodelist sendto and-left and-right not-left not-right
X; top-levels-eq add-token real-add-token remove-old
X; remove-old-num remove-old-no-num removecs insertcs dsort
X; best-of best-of* conflict-set-compare =alg ))
X
X
X;;; Functions that were revised so that they would compile efficiently
X
X
X;* The function == is machine dependent\!
X;* This function compares small integers for equality. It uses EQ
X;* so that it will be fast, and it will consequently not work on all
X;* Lisps. It works in Franz Lisp for integers in [-128, 127]
X
X
X;(defun == (&rest z) (= (cadr z) (caddr z)))
X(defun == (x y) (= x y))
X
X; =ALG returns T if A and B are algebraicly equal.
X
X(defun =alg (a b) (= a b))
X
X(defmacro fast-symeval (&rest z)
X `(cond ((eq ,(car z) '*c1*) *c1*)
X ((eq ,(car z) '*c2*) *c2*)
X ((eq ,(car z) '*c3*) *c3*)
X ((eq ,(car z) '*c4*) *c4*)
X ((eq ,(car z) '*c5*) *c5*)
X ((eq ,(car z) '*c6*) *c6*)
X ((eq ,(car z) '*c7*) *c7*)
X (t (eval ,(car z))) ))
X
X; getvector and putvector are fast routines for using one-dimensional
X; arrays. these routines do no checking; they assume
X; 1. the array is a vector with 0 being the index of the first
X; element
X; 2. the vector holds arbitrary list values
X;defun versions are useful for tracing
X
X; Example call: (putvector array index value)
X
X(defmacro putvector (array_ref ind var)
X `(setf (aref ,array_ref ,ind) ,var))
X
X;(defun putvector (array_ref ind var)
X; (setf (aref array_ref ind) var))
X
X; Example call: (getvector name index)
X
X;(defmacro getvector(&rest z)
X; (list 'cxr (caddr z) (cadr z)))
X
X(defmacro getvector(array_ref ind)
X `(aref ,array_ref ,ind))
X
X;(defun getvector (array_ref ind)
X ; (aref array_ref ind))
X
X(defun ce-gelm (x k)
X (prog nil
X loop (and (== k 1.) (return (car x)))
X (setq k (1- k))
X (setq x (cdr x))
X (go loop)))
X
X; The loops in gelm were unwound so that fewer calls on DIFFERENCE
X; would be needed
X
X(defun gelm (x k)
X (prog (ce sub)
X (setq ce (floor (/ k 10000)))
X (setq sub (- k (* ce 10000)))
X celoop (and (== ce 0) (go ph2))
X (setq x (cdr x))
X (and (== ce 1) (go ph2))
X (setq x (cdr x))
X (and (== ce 2) (go ph2))
X (setq x (cdr x))
X (and (== ce 3) (go ph2))
X (setq x (cdr x))
X (and (== ce 4) (go ph2))
X (setq ce (- ce 4))
X (go celoop)
X ph2 (setq x (car x))
X subloop (and (== sub 0) (go finis))
X (setq x (cdr x))
X (and (== sub 1) (go finis))
X (setq x (cdr x))
X (and (== sub 2) (go finis))
X (setq x (cdr x))
X (and (== sub 3) (go finis))
X (setq x (cdr x))
X (and (== sub 4) (go finis))
X (setq x (cdr x))
X (and (== sub 5) (go finis))
X (setq x (cdr x))
X (and (== sub 6) (go finis))
X (setq x (cdr x))
X (and (== sub 7) (go finis))
X (setq x (cdr x))
X (and (== sub 8) (go finis))
X (setq sub (- sub 8))
X (go subloop)
X finis (return (car x))))
X
X
X;;; Utility functions
X
X
X
X(defun printline (x) (mapc (function printline*) x))
X
X(defun printline* (y) (princ '| |) (print y))
X
X(defun printlinec (x) (mapc (function printlinec*) x))
X
X(defun printlinec* (y) (princ '| |) (princ y))
X
X; intersect two lists using eq for the equality test
X
X(defun interq (x y)
X (intersection x y :test #'eq))
X
X(defun enter (x ll)
X (and (not (member x ll :test #'equal))
X (push x ll)))
X
X
X;Hack read-macro tables to accept single characters -- right out of CL book.
X(defun single-macro-character (stream char)
X (declare (ignore stream))
X (character char))
X
X(defun i-g-v nil
X (prog (x)
X (set-macro-character #\{ #'single-macro-character )
X (set-macro-character #\} #'single-macro-character )
X (set-macro-character #\^ #'single-macro-character )
X; (setsyntax '\{ 66.) ;These are already normal characters in CL
X; (setsyntax '\} 66.)
X; (setsyntax '^ 66.)
X (setq *buckets* 64.) ; OPS5 allows 64 named slots
X (setq *accept-file* nil)
X (setq *write-file* nil)
X (setq *trace-file* nil)
X (and (boundp '*class-list*)
X (mapc #'(lambda(class) (putprop class nil 'att-list)) *class-list*))
X (setq *class-list* nil)
X (setq *brkpts* nil)
X (setq *strategy* 'lex)
X (setq *in-rhs* nil)
X (setq *ptrace* t)
X (setq *wtrace* nil)
X (setq *mtrace* t) ; turn on made-by tracing
X (setq *madeby* nil) ; record makers of wm elements
X (setq *recording* nil)
X (setq *refracts* nil)
X (setq *real-cnt* (setq *virtual-cnt* 0.))
X (setq *max-cs* (setq *total-cs* 0.))
X (setq *limit-token* 1000000.)
X (setq *limit-cs* 1000000.)
X (setq *critical* nil)
X (setq *build-trace* nil)
X (setq *wmpart-list* nil)
X (setq *pnames* nil)
X (setq *literals* nil) ; records literal definitions
X (setq *externals* nil) ; records external definitions
X (setq *vector-attributes* nil) ;records vector attributes
X (setq *size-result-array* 127.)
X (setq *result-array* (make-array 128))
X (setq *record-array* (make-array 128))
X (setq x 0)
X (setq *pnames* nil) ; list of production names
X loop (putvector *result-array* x nil)
X (setq x (1+ x))
X (and (not (> x *size-result-array*)) (go loop))
X (make-bottom-node)
X (setq *pcount* 0.)
X (initialize-record)
X (setq *cycle-count* (setq *action-count* 0.))
X (setq *total-token*
X (setq *max-token* (setq *current-token* 0.)))
X (setq *total-cs* (setq *max-cs* 0.))
X (setq *total-wm* (setq *max-wm* (setq *current-wm* 0.)))
X (setq *conflict-set* nil)
X (setq *wmpart-list* nil)
X (setq *p-name* nil)
X (setq *remaining-cycles* 1000000)
X))
X
X; if the size of result-array changes, change the line in i-g-v which
X; sets the value of *size-result-array*
X
X(defun %warn (what where)
X (prog nil
X (terpri)
X (princ '?)
X (and *p-name* (princ *p-name*))
X (princ '|..|)
X (princ where)
X (princ '|..|)
X (princ what)
X (return where)))
X
X(defun %error (what where)
X (%warn what where)
X (throw '!error! nil))
X
X
X(defun top-levels-eq (la lb)
X (prog nil
X lx (cond ((eq la lb) (return t))
X ((null la) (return nil))
X ((null lb) (return nil))
X ((not (eq (car la) (car lb))) (return nil)))
X (setq la (cdr la))
X (setq lb (cdr lb))
X (go lx)))
X
X
X;;; LITERAL and LITERALIZE
X
X(defmacro literal (&rest z)
X `(prog (atm val old args)
X (setq args ',z)
X top (and (atom args) (return 'bound))
X (or (eq (cadr args) '=) (return (%warn '|wrong format| args)))
X (setq atm (car args))
X (setq val (caddr args))
X (setq args (cdddr args))
X (cond ((not (numberp val))
X (%warn '|can bind only to numbers| val))
X ((or (not (symbolp atm)) (variablep atm))
X (%warn '|can bind only constant atoms| atm))
X ((and (setq old (literal-binding-of atm)) (not (equal old val)))
X (%warn '|attempt to rebind attribute| atm))
X (t (putprop atm val 'ops-bind )))
X (go top)))
X
X(defmacro literalize (&rest l)
X `(prog (class-name atts)
X (setq class-name (car ',l))
X (cond ((have-compiled-production)
X (%warn '|literalize called after p| class-name)
X (return nil))
X ((get class-name 'att-list)
X (%warn '|attempt to redefine class| class-name)
X (return nil)))
X (setq *class-list* (cons class-name *class-list*))
X (setq atts (remove-duplicates (cdr ',l)))
X (test-attribute-names atts)
X (mark-conflicts atts atts)
X (putprop class-name atts 'att-list)))
X
X(defmacro vector-attribute (&rest l)
X `(cond ((have-compiled-production)
X (%warn '|vector-attribute called after p| ',l))
X (t
X (test-attribute-names ',l)
X (mapc (function vector-attribute2) ',l))))
X
X(defun vector-attribute2 (att) (putprop att t 'vector-attribute)
X (setq *vector-attributes*
X (enter att *vector-attributes*)))
X
X(defun is-vector-attribute (att) (get att 'vector-attribute))
X
X(defun test-attribute-names (l)
X (mapc (function test-attribute-names2) l))
X
X(defun test-attribute-names2 (atm)
X (cond ((or (not (symbolp atm)) (variablep atm))
X (%warn '|can bind only constant atoms| atm))))
X
X(defun finish-literalize nil
X (cond ((not (null *class-list*))
X (mapc (function note-user-assigns) *class-list*)
X (mapc (function assign-scalars) *class-list*)
X (mapc (function assign-vectors) *class-list*)
X (mapc (function put-ppdat) *class-list*)
X (mapc (function erase-literal-info) *class-list*)
X (setq *class-list* nil)
X (setq *buckets* nil))))
X
X(defun have-compiled-production nil (not (zerop *pcount*)))
X
X(defun put-ppdat (class)
X (prog (al att ppdat)
X (setq ppdat nil)
X (setq al (get class 'att-list))
X top (cond ((not (atom al))
X (setq att (car al))
X (setq al (cdr al))
X (setq ppdat
X (cons (cons (literal-binding-of att) att)
X ppdat))
X (go top)))
X (putprop class ppdat 'ppdat)))
X
X; note-user-assigns and note-user-vector-assigns are needed only when
X; literal and literalize are both used in a program. They make sure that
X; the assignments that are made explicitly with literal do not cause problems
X; for the literalized classes.
X
X(defun note-user-assigns (class)
X (mapc (function note-user-assigns2) (get class 'att-list)))
X
X(defun note-user-assigns2 (att)
X (prog (num conf buck clash)
X (setq num (literal-binding-of att))
X (and (null num) (return nil))
X (setq conf (get att 'conflicts))
X (setq buck (store-binding att num))
X (setq clash (find-common-atom buck conf))
X (and clash
X (%warn '|attributes in a class assigned the same number|
X (cons att clash)))
X (return nil)))
X
X(defun note-user-vector-assigns (att given needed)
X (and (> needed given)
X (%warn '|vector attribute assigned too small a value in literal| att)))
X
X(defun assign-scalars (class)
X (mapc (function assign-scalars2) (get class 'att-list)))
X
X(defun assign-scalars2 (att)
X (prog (tlist num bucket conf)
X (and (literal-binding-of att) (return nil))
X (and (is-vector-attribute att) (return nil))
X (setq tlist (buckets))
X (setq conf (get att 'conflicts))
X top (cond ((atom tlist)
X (%warn '|could not generate a binding| att)
X (store-binding att -1.)
X (return nil)))
X (setq num (caar tlist))
X (setq bucket (cdar tlist))
X (setq tlist (cdr tlist))
X (cond ((disjoint bucket conf) (store-binding att num))
X (t (go top)))))
X
X(defun assign-vectors (class)
X (mapc (function assign-vectors2) (get class 'att-list)))
X
X(defun assign-vectors2 (att)
X (prog (big conf new old need)
X (and (not (is-vector-attribute att)) (return nil))
X (setq big 1.)
X (setq conf (get att 'conflicts))
X top (cond ((not (atom conf))
X (setq new (car conf))
X (setq conf (cdr conf))
X (cond ((is-vector-attribute new)
X (%warn '|class has two vector attributes|
X (list att new)))
X (t (setq big (max (literal-binding-of new) big))))
X (go top)))
X (setq need (1+ big))
X (setq old (literal-binding-of att))
X (cond (old (note-user-vector-assigns att old need))
X (t (store-binding att need)))
X (return nil)))
X
X(defun disjoint (la lb) (not (find-common-atom la lb)))
X
X(defun find-common-atom (la lb)
X (prog nil
X top (cond ((null la) (return nil))
X ((member (car la) lb :test #'eq) (return (car la)))
X (t (setq la (cdr la)) (go top)))))
X
X(defun mark-conflicts (rem all)
X (cond ((not (null rem))
X (mark-conflicts2 (car rem) all)
X (mark-conflicts (cdr rem) all))))
X
X(defun mark-conflicts2 (atm lst)
X (prog (l)
X (setq l lst)
X top (and (atom l) (return nil))
X (conflict atm (car l))
X (setq l (cdr l))
X (go top)))
X
X(defun conflict (a b)
X (prog (old)
X (setq old (get a 'conflicts))
X (and (not (eq a b))
X (not (member b old :test #'eq))
X (putprop a (cons b old) 'conflicts ))))
X
X;(defun remove-duplicates (lst)
X; (cond ((atom lst) nil)
X; ((member (car lst) (cdr lst) :test #'eq) (remove-duplicates (cdr lst)))
X; (t (cons (car lst) (remove-duplicates (cdr lst))))))
X
X(defun literal-binding-of (name) (get name 'ops-bind))
X
X(defun store-binding (name lit)
X (putprop name lit 'ops-bind)
X (add-bucket name lit))
X
X(defun add-bucket (name num)
X (prog (buc)
X (setq buc (assoc num (buckets)))
X (and (not (member name buc :test #'eq))
X (rplacd buc (cons name (cdr buc))))
X (return buc)))
X
X(defun buckets nil
X (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
X *buckets*)
X
X(defun make-nums (k)
X (prog (nums)
X (setq nums nil)
X l (and (< k 2.) (return nums))
X (setq nums (cons (cons k nil) nums))
X (setq k (1- k))
X (go l)))
X
X;(defun erase-literal-info (class)
X; (mapc (function erase-literal-info2) (get class 'att-list))
X; (remprop class 'att-list))
X
X; modified to record literal info in the variable *literals*
X(defun erase-literal-info (class)
X (setq *literals*
X (cons (cons class (get class 'att-list)) *literals*))
X (mapc (function erase-literal-info2) (get class 'att-list))
X (remprop class 'att-list))
X
X
X(defun erase-literal-info2 (att) (remprop att 'conflicts))
X
X
X;;; LHS Compiler
X
X(defmacro p (&rest z)
X `(progn
X (finish-literalize)
X (princ '*)
X ;(drain);drain probably drains a line feed
X (compile-production (car ',z) (cdr ',z))))
X
X(defun compile-production (name matrix)
X (prog (erm)
X (setq *p-name* name)
X (setq erm (catch '!error! (cmp-p name matrix) ))
X ; following line is modified to save production name on *pnames*
X (and (null erm) (setq *pnames* (enter name *pnames*)))
X (setq *p-name* nil)
X (return erm)))
X
X(defun peek-lex nil (car *matrix*))
X
X(defun lex nil
X (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*))))
X
X(defun end-of-p nil (atom *matrix*))
X
X(defun rest-of-p nil *matrix*)
X
X(defun prepare-lex (prod) (setq *matrix* prod))
X
X
X(defun peek-sublex nil (car *curcond*))
X
X(defun sublex nil
X (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*))))
X
X(defun end-of-ce nil (atom *curcond*))
X
X(defun rest-of-ce nil *curcond*)
X
X(defun prepare-sublex (ce) (setq *curcond* ce))
X
X(defun make-bottom-node nil (setq *first-node* (list '&bus nil)))
X
X(defun cmp-p (name matrix)
X (prog (m bakptrs)
X (cond ((or (null name) (listp name))
X (%error '|illegal production name| name))
X ((equal (get name 'production) matrix)
X (return nil)))
X (prepare-lex matrix)
X (excise-p name)
X (setq bakptrs nil)
X (setq *pcount* (1+ *pcount*))
X (setq *feature-count* 0.)
X (setq *ce-count* 0)
X (setq *vars* nil)
X (setq *ce-vars* nil)
X (setq *rhs-bound-vars* nil)
X (setq *rhs-bound-ce-vars* nil)
X (setq *last-branch* nil)
X (setq m (rest-of-p))
X l1 (and (end-of-p) (%error '|no '-->' in production| m))
X (cmp-prin)
X (setq bakptrs (cons *last-branch* bakptrs))
X (or (eq '--> (peek-lex)) (go l1))
X (lex)
X (check-rhs (rest-of-p))
X (link-new-node (list '&p
X *feature-count*
X name
X (encode-dope)
X (encode-ce-dope)
X (cons 'progn (rest-of-p))))
X (putprop name (cdr (nreverse bakptrs)) 'backpointers )
X (putprop name matrix 'production)
X (putprop name *last-node* 'topnode)))
X
X(defun rating-part (pnode) (cadr pnode))
X
X(defun var-part (pnode) (car (cdddr pnode)))
X
X(defun ce-var-part (pnode) (cadr (cdddr pnode)))
X
X(defun rhs-part (pnode) (caddr (cdddr pnode)))
X
X(defun excise-p (name)
X (cond ((and (symbolp name) (get name 'topnode))
X (printline (list name 'is 'excised))
X (setq *pcount* (1- *pcount*))
X (remove-from-conflict-set name)
X (kill-node (get name 'topnode))
X (setq *pnames* (delete name *pnames* :test #'eq))
X (remprop name 'production)
X (remprop name 'backpointers)
X (remprop name 'topnode))))
X
X(defun kill-node (node)
X (prog nil
X top (and (atom node) (return nil))
X (rplaca node '&old)
X (setq node (cdr node))
X (go top)))
X
X(defun cmp-prin nil
X (prog nil
X (setq *last-node* *first-node*)
X (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
X ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
X (t (cmp-posce) (cmp-and)))))
X
X(defun cmp-negce nil (lex) (cmp-ce))
X
X(defun cmp-posce nil
X (setq *ce-count* (1+ *ce-count*))
X (cond ((eq (peek-lex) #\{) (cmp-ce+cevar))
X (t (cmp-ce))))
X
X(defun cmp-ce+cevar nil
X (prog (z)
X (lex)
X (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
X (t (cmp-ce) (cmp-cevar)))
X (setq z (lex))
X (or (eq z #\}) (%error '|missing '}'| z))))
X
X(defun new-subnum (k)
X (or (numberp k) (%error '|tab must be a number| k))
X (setq *subnum* (round k)))
X
X(defun incr-subnum nil (setq *subnum* (1+ *subnum*)))
X
X(defun cmp-ce nil
X (prog (z)
X (new-subnum 0.)
X (setq *cur-vars* nil)
X (setq z (lex))
X (and (atom z)
X (%error '|atomic conditions are not allowed| z))
X (prepare-sublex z)
X la (and (end-of-ce) (return nil))
X (incr-subnum)
X (cmp-element)
X (go la)))
X
X(defun cmp-element nil
X (and (eq (peek-sublex) #\^) (cmp-tab))
X (cond ((eq (peek-sublex) '#\{) (cmp-product))
X (t (cmp-atomic-or-any))))
X
X(defun cmp-atomic-or-any nil
X (cond ((eq (peek-sublex) '<<) (cmp-any))
X (t (cmp-atomic))))
X
X(defun cmp-any nil
X (prog (a z)
X (sublex)
X (setq z nil)
X la (cond ((end-of-ce) (%error '|missing '>>'| a)))
X (setq a (sublex))
X (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
X (link-new-node (list '&any nil (current-field) z))))
X
X
X(defun cmp-tab nil
X (prog (r)
X (sublex)
X (setq r (sublex))
X (setq r ($litbind r))
X (new-subnum r)))
X
X(defun $litbind (x)
X (prog (r)
X (cond ((and (symbolp x) (setq r (literal-binding-of x)))
X (return r))
X (t (return x)))))
X
X(defun get-bind (x)
X (prog (r)
X (cond ((and (symbolp x) (setq r (literal-binding-of x)))
X (return r))
X (t (return nil)))))
X
X(defun cmp-atomic nil
X (prog (test x)
X (setq x (peek-sublex))
X (cond ((eq x '=) (setq test 'eq) (sublex))
X ((eq x '<>) (setq test 'ne) (sublex))
X ((eq x '<) (setq test 'lt) (sublex))
X ((eq x '<=) (setq test 'le) (sublex))
X ((eq x '>) (setq test 'gt) (sublex))
X ((eq x '>=) (setq test 'ge) (sublex))
X ((eq x '<=>) (setq test 'xx) (sublex))
X (t (setq test 'eq)))
X (cmp-symbol test)))
X
X(defun cmp-product nil
X (prog (save)
X (setq save (rest-of-ce))
X (sublex)
X la (cond ((end-of-ce)
X (cond ((member #\} save)
X (%error '|wrong contex for '}'| save))
X (t (%error '|missing '}'| save))))
X ((eq (peek-sublex) #\}) (sublex) (return nil)))
X (cmp-atomic-or-any)
X (go la)))
X
X(defun variablep (x) (and (symbolp x) (char-equal (char (symbol-name x) 0) #\<)))
X
X(defun cmp-symbol (test)
X (prog (flag)
X (setq flag t)
X (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
X (cond ((and flag (variablep (peek-sublex)))
X (cmp-var test))
X ((numberp (peek-sublex)) (cmp-number test))
X ((symbolp (peek-sublex)) (cmp-constant test))
X (t (%error '|unrecognized symbol| (sublex))))))
X
X(defun concat3(x y z)
X (intern (format nil "~s~s~s" x y z)))
X
X(defun cmp-constant (test)
X (or (member test '(eq ne xx) )
X (%error '|non-numeric constant after numeric predicate| (sublex)))
X (link-new-node (list (concat3 't test 'a)
X nil
X (current-field)
X (sublex))))
X
X
X(defun cmp-number (test)
X (link-new-node (list (concat3 't test 'n)
X nil
X (current-field)
X (sublex))))
X
X(defun current-field nil (field-name *subnum*))
X
X(defun field-name (num)
X (cond ((= num 1.) '*c1*)
X ((= num 2.) '*c2*)
X ((= num 3.) '*c3*)
X ((= num 4.) '*c4*)
X ((= num 5.) '*c5*)
X ((= num 6.) '*c6*)
X ((= num 7.) '*c7*)
X ((= num 8.) '*c8*)
X ((= num 9.) '*c9*)
X ((= num 10.) '*c10*)
X ((= num 11.) '*c11*)
X ((= num 12.) '*c12*)
X ((= num 13.) '*c13*)
X ((= num 14.) '*c14*)
X ((= num 15.) '*c15*)
X ((= num 16.) '*c16*)
X ((= num 17.) '*c17*)
X ((= num 18.) '*c18*)
X ((= num 19.) '*c19*)
X ((= num 20.) '*c20*)
X ((= num 21.) '*c21*)
X ((= num 22.) '*c22*)
X ((= num 23.) '*c23*)
X ((= num 24.) '*c24*)
X ((= num 25.) '*c25*)
X ((= num 26.) '*c26*)
X ((= num 27.) '*c27*)
X ((= num 28.) '*c28*)
X ((= num 29.) '*c29*)
X ((= num 30.) '*c30*)
X ((= num 31.) '*c31*)
X ((= num 32.) '*c32*)
X ((= num 33.) '*c33*)
X ((= num 34.) '*c34*)
X ((= num 35.) '*c35*)
X ((= num 36.) '*c36*)
X ((= num 37.) '*c37*)
X ((= num 38.) '*c38*)
X ((= num 39.) '*c39*)
X ((= num 40.) '*c40*)
X ((= num 41.) '*c41*)
X ((= num 42.) '*c42*)
X ((= num 43.) '*c43*)
X ((= num 44.) '*c44*)
X ((= num 45.) '*c45*)
X ((= num 46.) '*c46*)
X ((= num 47.) '*c47*)
X ((= num 48.) '*c48*)
X ((= num 49.) '*c49*)
X ((= num 50.) '*c50*)
X ((= num 51.) '*c51*)
X ((= num 52.) '*c52*)
X ((= num 53.) '*c53*)
X ((= num 54.) '*c54*)
X ((= num 55.) '*c55*)
X ((= num 56.) '*c56*)
X ((= num 57.) '*c57*)
X ((= num 58.) '*c58*)
X ((= num 59.) '*c59*)
X ((= num 60.) '*c60*)
X ((= num 61.) '*c61*)
X ((= num 62.) '*c62*)
X ((= num 63.) '*c63*)
X ((= num 64.) '*c64*)
X (t (%error '|condition is too long| (rest-of-ce)))))
X
X
X;;; Compiling variables
X;
X;
X;
X; *cur-vars* are the variables in the condition element currently
X; being compiled. *vars* are the variables in the earlier condition
X; elements. *ce-vars* are the condition element variables. note
X; that the interpreter will not confuse condition element and regular
X; variables even if they have the same name.
X;
X; *cur-vars* is a list of triples: (name predicate subelement-number)
X; eg: ( (<x> eq 3)
X; (<y> ne 1)
X; . . . )
X;
X; *vars* is a list of triples: (name ce-number subelement-number)
X; eg: ( (<x> 3 3)
X; (<y> 1 1)
X; . . . )
X;
X; *ce-vars* is a list of pairs: (name ce-number)
X; eg: ( (ce1 1)
X; (<c3> 3)
X; . . . )
X
X(defun var-dope (var) (assoc var *vars* :test #'eq))
X
X(defun ce-var-dope (var) (assoc var *ce-vars* :test #'eq))
X
X(defun cmp-var (test)
X (prog (old name)
X (setq name (sublex))
X (setq old (assoc name *cur-vars* :test #'eq))
X (cond ((and old (eq (cadr old) 'eq))
X (cmp-old-eq-var test old))
X ((and old (eq test 'eq)) (cmp-new-eq-var name old))
X (t (cmp-new-var name test)))))
X
X(defun cmp-new-var (name test)
X (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*)))
X
X(defun cmp-old-eq-var (test old)
X (link-new-node (list (concat3 't test 's)
X nil
X (current-field)
X (field-name (caddr old)))))
X
X(defun cmp-new-eq-var (name old)
X (prog (pred next)
X (setq *cur-vars* (delete old *cur-vars* :test #'eq))
X (setq next (assoc name *cur-vars* :test #'eq))
X (cond (next (cmp-new-eq-var name next))
X (t (cmp-new-var name 'eq)))
X (setq pred (cadr old))
X (link-new-node (list (concat3 't pred 's)
X nil
X (field-name (caddr old))
X (current-field)))))
X
X(defun cmp-cevar nil
X (prog (name old)
X (setq name (lex))
X (setq old (assoc name *ce-vars* :test #'eq))
X (and old
X (%error '|condition element variable used twice| name))
X (setq *ce-vars* (cons (list name 0.) *ce-vars*))))
X
X(defun cmp-not nil (cmp-beta '¬))
X
X(defun cmp-nobeta nil (cmp-beta nil))
X
X(defun cmp-and nil (cmp-beta '&and))
X
X(defun cmp-beta (kind)
X (prog (tlist vdope vname vpred vpos old)
X (setq tlist nil)
X la (and (atom *cur-vars*) (go lb))
X (setq vdope (car *cur-vars*))
X (setq *cur-vars* (cdr *cur-vars*))
X (setq vname (car vdope))
X (setq vpred (cadr vdope))
X (setq vpos (caddr vdope))
X (setq old (assoc vname *vars* :test #'eq))
X (cond (old (setq tlist (add-test tlist vdope old)))
X ((not (eq kind '¬)) (promote-var vdope)))
X (go la)
X lb (and kind (build-beta kind tlist))
X (or (eq kind '¬) (fudge))
X (setq *last-branch* *last-node*)))
X
X(defun add-test (list new old)
X (prog (ttype lloc rloc)
X (setq *feature-count* (1+ *feature-count*))
X (setq ttype (concat3 't (cadr new) 'b))
X (setq rloc (encode-singleton (caddr new)))
X (setq lloc (encode-pair (cadr old) (caddr old)))
X (return (cons ttype (cons lloc (cons rloc list))))))
X
--
---------------
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-9400turner@imagen.UUCP (D'arc Angel) (01/19/87)
X; the following two functions encode indices so that gelm can
X; decode them as fast as possible
X
X(defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b)))
X
X(defun encode-singleton (a) (1- a))
X
X(defun promote-var (dope)
X (prog (vname vpred vpos new)
X (setq vname (car dope))
X (setq vpred (cadr dope))
X (setq vpos (caddr dope))
X (or (eq 'eq vpred)
X (%error '|illegal predicate for first occurrence|
X (list vname vpred)))
X (setq new (list vname 0. vpos))
X (setq *vars* (cons new *vars*))))
X
X(defun fudge nil
X (mapc (function fudge*) *vars*)
X (mapc (function fudge*) *ce-vars*))
X
X(defun fudge* (z)
X (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a)))))
X
X(defun build-beta (type tests)
X (prog (rpred lpred lnode lef)
X (link-new-node (list '&mem nil nil (protomem)))
X (setq rpred *last-node*)
X (cond ((eq type '&and)
X (setq lnode (list '&mem nil nil (protomem))))
X (t (setq lnode (list '&two nil nil))))
X (setq lpred (link-to-branch lnode))
X (cond ((eq type '&and) (setq lef lpred))
X (t (setq lef (protomem))))
X (link-new-beta-node (list type nil lef rpred tests))))
X
X(defun protomem nil (list nil))
X
X(defun memory-part (mem-node) (car (cadddr mem-node)))
X
X(defun encode-dope nil
X (prog (r all z k)
X (setq r nil)
X (setq all *vars*)
X la (and (atom all) (return r))
X (setq z (car all))
X (setq all (cdr all))
X (setq k (encode-pair (cadr z) (caddr z)))
X (setq r (cons (car z) (cons k r)))
X (go la)))
X
X(defun encode-ce-dope nil
X (prog (r all z k)
X (setq r nil)
X (setq all *ce-vars*)
X la (and (atom all) (return r))
X (setq z (car all))
X (setq all (cdr all))
X (setq k (cadr z))
X (setq r (cons (car z) (cons k r)))
X (go la)))
X
X
X
X;;; Linking the nodes
X
X(defun link-new-node (r)
X (cond ((not (member (car r) '(&p &mem &two &and ¬)))
X (setq *feature-count* (1+ *feature-count*))))
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-node* (link-left *last-node* r)))
X
X(defun link-to-branch (r)
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-branch* (link-left *last-branch* r)))
X
X(defun link-new-beta-node (r)
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-node* (link-both *last-branch* *last-node* r))
X (setq *last-branch* *last-node*))
X
X(defun link-left (pred succ)
X (prog (a r)
X (setq a (left-outs pred))
X (setq r (find-equiv-node succ a))
X (and r (return r))
X (setq *real-cnt* (1+ *real-cnt*))
X (attach-left pred succ)
X (return succ)))
X
X(defun link-both (left right succ)
X (prog (a r)
X (setq a (interq (left-outs left) (right-outs right)))
X (setq r (find-equiv-beta-node succ a))
X (and r (return r))
X (setq *real-cnt* (1+ *real-cnt*))
X (attach-left left succ)
X (attach-right right succ)
X (return succ)))
X
X(defun attach-right (old new)
X (rplaca (cddr old) (cons new (caddr old))))
X
X(defun attach-left (old new)
X (rplaca (cdr old) (cons new (cadr old))))
X
X(defun right-outs (node) (caddr node))
X
X(defun left-outs (node) (cadr node))
X
X(defun find-equiv-node (node list)
X (prog (a)
X (setq a list)
X l1 (cond ((atom a) (return nil))
X ((equiv node (car a)) (return (car a))))
X (setq a (cdr a))
X (go l1)))
X
X(defun find-equiv-beta-node (node list)
X (prog (a)
X (setq a list)
X l1 (cond ((atom a) (return nil))
X ((beta-equiv node (car a)) (return (car a))))
X (setq a (cdr a))
X (go l1)))
X
X; do not look at the predecessor fields of beta nodes; they have to be
X; identical because of the way the candidate nodes were found
X
X(defun equiv (a b)
X (and (eq (car a) (car b))
X (or (eq (car a) '&mem)
X (eq (car a) '&two)
X (equal (caddr a) (caddr b)))
X (equal (cdddr a) (cdddr b))))
X
X(defun beta-equiv (a b)
X (and (eq (car a) (car b))
X (equal (cddddr a) (cddddr b))
X (or (eq (car a) '&and) (equal (caddr a) (caddr b)))))
X
X; the equivalence tests are set up to consider the contents of
X; node memories, so they are ready for the build action
X
X;;; Network interpreter
X
X(defun match (flag wme)
X (sendto flag (list wme) 'left (list *first-node*)))
X
X; note that eval-nodelist is not set up to handle building
X; productions. would have to add something like ops4's build-flag
X
X(defun eval-nodelist (nl)
X (prog nil
X top (and (not nl) (return nil))
X (setq *sendtocall* nil)
X (setq *last-node* (car nl))
X (apply (caar nl) (cdar nl))
X (setq nl (cdr nl))
X (go top)))
X
X(defun sendto (flag data side nl)
X (prog nil
X top (and (not nl) (return nil))
X (setq *side* side)
X (setq *flag-part* flag)
X (setq *data-part* data)
X (setq *sendtocall* t)
X (setq *last-node* (car nl))
X (apply (caar nl) (cdar nl))
X (setq nl (cdr nl))
X (go top)))
X
X; &bus sets up the registers for the one-input nodes. note that this
X(defun &bus (outs)
X (prog (dp)
X (setq *alpha-flag-part* *flag-part*)
X (setq *alpha-data-part* *data-part*)
X (setq dp (car *data-part*))
X (setq *c1* (car dp))
X (setq dp (cdr dp))
X (setq *c2* (car dp))
X (setq dp (cdr dp))
X (setq *c3* (car dp))
X (setq dp (cdr dp))
X (setq *c4* (car dp))
X (setq dp (cdr dp))
X (setq *c5* (car dp))
X (setq dp (cdr dp))
X (setq *c6* (car dp))
X (setq dp (cdr dp))
X (setq *c7* (car dp))
X (setq dp (cdr dp))
X (setq *c8* (car dp))
X (setq dp (cdr dp))
X (setq *c9* (car dp))
X (setq dp (cdr dp))
X (setq *c10* (car dp))
X (setq dp (cdr dp))
X (setq *c11* (car dp))
X (setq dp (cdr dp))
X (setq *c12* (car dp))
X (setq dp (cdr dp))
X (setq *c13* (car dp))
X (setq dp (cdr dp))
X (setq *c14* (car dp))
X (setq dp (cdr dp))
X (setq *c15* (car dp))
X (setq dp (cdr dp))
X (setq *c16* (car dp))
X (setq dp (cdr dp))
X (setq *c17* (car dp))
X (setq dp (cdr dp))
X (setq *c18* (car dp))
X (setq dp (cdr dp))
X (setq *c19* (car dp))
X (setq dp (cdr dp))
X (setq *c20* (car dp))
X (setq dp (cdr dp))
X (setq *c21* (car dp))
X (setq dp (cdr dp))
X (setq *c22* (car dp))
X (setq dp (cdr dp))
X (setq *c23* (car dp))
X (setq dp (cdr dp))
X (setq *c24* (car dp))
X (setq dp (cdr dp))
X (setq *c25* (car dp))
X (setq dp (cdr dp))
X (setq *c26* (car dp))
X (setq dp (cdr dp))
X (setq *c27* (car dp))
X (setq dp (cdr dp))
X (setq *c28* (car dp))
X (setq dp (cdr dp))
X (setq *c29* (car dp))
X (setq dp (cdr dp))
X (setq *c30* (car dp))
X (setq dp (cdr dp))
X (setq *c31* (car dp))
X (setq dp (cdr dp))
X (setq *c32* (car dp))
X (setq dp (cdr dp))
X (setq *c33* (car dp))
X (setq dp (cdr dp))
X (setq *c34* (car dp))
X (setq dp (cdr dp))
X (setq *c35* (car dp))
X (setq dp (cdr dp))
X (setq *c36* (car dp))
X (setq dp (cdr dp))
X (setq *c37* (car dp))
X (setq dp (cdr dp))
X (setq *c38* (car dp))
X (setq dp (cdr dp))
X (setq *c39* (car dp))
X (setq dp (cdr dp))
X (setq *c40* (car dp))
X (setq dp (cdr dp))
X (setq *c41* (car dp))
X (setq dp (cdr dp))
X (setq *c42* (car dp))
X (setq dp (cdr dp))
X (setq *c43* (car dp))
X (setq dp (cdr dp))
X (setq *c44* (car dp))
X (setq dp (cdr dp))
X (setq *c45* (car dp))
X (setq dp (cdr dp))
X (setq *c46* (car dp))
X (setq dp (cdr dp))
X (setq *c47* (car dp))
X (setq dp (cdr dp))
X (setq *c48* (car dp))
X (setq dp (cdr dp))
X (setq *c49* (car dp))
X (setq dp (cdr dp))
X (setq *c50* (car dp))
X (setq dp (cdr dp))
X (setq *c51* (car dp))
X (setq dp (cdr dp))
X (setq *c52* (car dp))
X (setq dp (cdr dp))
X (setq *c53* (car dp))
X (setq dp (cdr dp))
X (setq *c54* (car dp))
X (setq dp (cdr dp))
X (setq *c55* (car dp))
X (setq dp (cdr dp))
X (setq *c56* (car dp))
X (setq dp (cdr dp))
X (setq *c57* (car dp))
X (setq dp (cdr dp))
X (setq *c58* (car dp))
X (setq dp (cdr dp))
X (setq *c59* (car dp))
X (setq dp (cdr dp))
X (setq *c60* (car dp))
X (setq dp (cdr dp))
X (setq *c61* (car dp))
X (setq dp (cdr dp))
X (setq *c62* (car dp))
X (setq dp (cdr dp))
X (setq *c63* (car dp))
X (setq dp (cdr dp))
X (setq *c64* (car dp))
X (eval-nodelist outs)))
X
X(defun &any (outs register const-list)
X (prog (z c)
X (setq z (fast-symeval register))
X (cond ((numberp z) (go number)))
X symbol (cond ((null const-list) (return nil))
X ((eq (car const-list) z) (go ok))
X (t (setq const-list (cdr const-list)) (go symbol)))
X number (cond ((null const-list) (return nil))
X ((and (numberp (setq c (car const-list)))
X (=alg c z))
X (go ok))
X (t (setq const-list (cdr const-list)) (go number)))
X ok (eval-nodelist outs)))
X
X(defun teqa (outs register constant)
X (and (eq (fast-symeval register) constant) (eval-nodelist outs)))
X
X(defun tnea (outs register constant)
X (and (not (eq (fast-symeval register) constant)) (eval-nodelist outs)))
X
X(defun txxa (outs register constant)
X (and (symbolp (fast-symeval register)) (eval-nodelist outs)))
X
X(defun teqn (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (=alg z constant)
X (eval-nodelist outs))))
X
X(defun tnen (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (or (not (numberp z))
X (not (=alg z constant)))
X (eval-nodelist outs))))
X
X(defun txxn (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z) (eval-nodelist outs))))
X
X(defun tltn (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (greaterp constant z)
X (eval-nodelist outs))))
X
X(defun tgtn (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (greaterp z constant)
X (eval-nodelist outs))))
X
X(defun tgen (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (not (greaterp constant z))
X (eval-nodelist outs))))
X
X(defun tlen (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (not (greaterp z constant))
X (eval-nodelist outs))))
X
X(defun teqs (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (cond ((eq a b) (eval-nodelist outs))
X ((and (numberp a)
X (numberp b)
X (=alg a b))
X (eval-nodelist outs)))))
X
X(defun tnes (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (cond ((eq a b) (return nil))
X ((and (numberp a)
X (numberp b)
X (=alg a b))
X (return nil))
X (t (eval-nodelist outs)))))
X
X(defun txxs (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (cond ((and (numberp a) (numberp b)) (eval-nodelist outs))
X ((and (not (numberp a)) (not (numberp b)))
X (eval-nodelist outs)))))
X
X(defun tlts (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (and (numberp a)
X (numberp b)
X (greaterp b a)
X (eval-nodelist outs))))
X
X(defun tgts (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (and (numberp a)
X (numberp b)
X (greaterp a b)
X (eval-nodelist outs))))
X
X(defun tges (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (and (numberp a)
X (numberp b)
X (not (greaterp b a))
X (eval-nodelist outs))))
X
X(defun tles (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (and (numberp a)
X (numberp b)
X (not (greaterp a b))
X (eval-nodelist outs))))
X
X(defun &two (left-outs right-outs)
X (prog (fp dp)
X (cond (*sendtocall*
X (setq fp *flag-part*)
X (setq dp *data-part*))
X (t
X (setq fp *alpha-flag-part*)
X (setq dp *alpha-data-part*)))
X (sendto fp dp 'left left-outs)
X (sendto fp dp 'right right-outs)))
X
X(defun &mem (left-outs right-outs memory-list)
X (prog (fp dp)
X (cond (*sendtocall*
X (setq fp *flag-part*)
X (setq dp *data-part*))
X (t
X (setq fp *alpha-flag-part*)
X (setq dp *alpha-data-part*)))
X (sendto fp dp 'left left-outs)
X (add-token memory-list fp dp nil)
X (sendto fp dp 'right right-outs)))
X
X(defun &and (outs lpred rpred tests)
X (prog (mem)
X (cond ((eq *side* 'right) (setq mem (memory-part lpred)))
X (t (setq mem (memory-part rpred))))
X (cond ((not mem) (return nil))
X ((eq *side* 'right) (and-right outs mem tests))
X (t (and-left outs mem tests)))))
X
X(defun and-left (outs mem tests)
X (prog (fp dp memdp tlist tst lind rind res)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X fail (and (null mem) (return nil))
X (setq memdp (car mem))
X (setq mem (cdr mem))
X (setq tlist tests)
X tloop (and (null tlist) (go succ))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X ;the next line differs in and-left & -right
X (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
X (cond (res (go tloop))
X (t (go fail)))
X succ ;the next line differs in and-left & -right
X (sendto fp (cons (car memdp) dp) 'left outs)
X (go fail)))
X
X(defun and-right (outs mem tests)
X (prog (fp dp memdp tlist tst lind rind res)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X fail (and (null mem) (return nil))
X (setq memdp (car mem))
X (setq mem (cdr mem))
X (setq tlist tests)
X tloop (and (null tlist) (go succ))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X ;the next line differs in and-left & -right
X (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
X (cond (res (go tloop))
X (t (go fail)))
X succ ;the next line differs in and-left & -right
X (sendto fp (cons (car dp) memdp) 'right outs)
X (go fail)))
X
X
X(defun teqb (new eqvar)
X (cond ((eq new eqvar) t)
X ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((=alg new eqvar) t)
X (t nil)))
X
X(defun tneb (new eqvar)
X (cond ((eq new eqvar) nil)
X ((not (numberp new)) t)
X ((not (numberp eqvar)) t)
X ((=alg new eqvar) nil)
X (t t)))
X
X(defun tltb (new eqvar)
X (cond ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((greaterp eqvar new) t)
X (t nil)))
X
X(defun tgtb (new eqvar)
X (cond ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((greaterp new eqvar) t)
X (t nil)))
X
X(defun tgeb (new eqvar)
X (cond ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((not (greaterp eqvar new)) t)
X (t nil)))
X
X(defun tleb (new eqvar)
X (cond ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((not (greaterp new eqvar)) t)
X (t nil)))
X
X(defun txxb (new eqvar)
X (cond ((numberp new)
X (cond ((numberp eqvar) t)
X (t nil)))
X (t
X (cond ((numberp eqvar) nil)
X (t t)))))
X
X
X(defun &p (rating name var-dope ce-var-dope rhs)
X (prog (fp dp)
X (cond (*sendtocall*
X (setq fp *flag-part*)
X (setq dp *data-part*))
X (t
X (setq fp *alpha-flag-part*)
X (setq dp *alpha-data-part*)))
X (and (member fp '(nil old)) (removecs name dp))
X (and fp (insertcs name dp rating))))
X
X(defun &old (a b c d e) nil) ;a null function used for deleting node
X
X(defun ¬ (outs lmem rpred tests)
X (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil)
X ((eq *side* 'right) (not-right outs (car lmem) tests))
X (t (not-left outs (memory-part rpred) tests lmem))))
X
X(defun not-left (outs mem tests own-mem)
X (prog (fp dp memdp tlist tst lind rind res c)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X (setq c 0.)
X fail (and (null mem) (go fin))
X (setq memdp (car mem))
X (setq mem (cdr mem))
X (setq tlist tests)
X tloop (and (null tlist) (setq c (1+ c)) (go fail))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X ;the next line differs in not-left & -right
X (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
X (cond (res (go tloop))
X (t (go fail)))
X fin (add-token own-mem fp dp c)
X (and (== c 0.) (sendto fp dp 'left outs))))
X
X(defun not-right (outs mem tests)
X (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X (cond ((not fp) (setq inc -1.) (setq newfp 'new))
X ((eq fp 'new) (setq inc 1.) (setq newfp nil))
X (t (return nil)))
X fail (and (null mem) (return nil))
X (setq memdp (car mem))
X (setq newc (cadr mem))
X (setq tlist tests)
X tloop (and (null tlist) (go succ))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X ;the next line differs in not-left & -right
X (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
X (cond (res (go tloop))
X (t (setq mem (cddr mem)) (go fail)))
X succ (setq newc (+ inc newc))
X (rplaca (cdr mem) newc)
X (cond ((or (and (== inc -1.) (== newc 0.))
X (and (== inc 1.) (== newc 1.)))
X (sendto newfp memdp 'right outs)))
X (setq mem (cddr mem))
X (go fail)))
X
X
X
X;;; Node memories
X
X
X(defun add-token (memlis flag data-part num)
X (prog (was-present)
X (cond ((eq flag 'new)
X (setq was-present nil)
X (real-add-token memlis data-part num))
X ((not flag)
X (setq was-present (remove-old memlis data-part num)))
X ((eq flag 'old) (setq was-present t)))
X (return was-present)))
X
X(defun real-add-token (lis data-part num)
X (setq *current-token* (1+ *current-token*))
X (cond (num (rplaca lis (cons num (car lis)))))
X (rplaca lis (cons data-part (car lis))))
X
X(defun remove-old (lis data num)
X (cond (num (remove-old-num lis data))
X (t (remove-old-no-num lis data))))
X
X(defun remove-old-num (lis data)
X (prog (m next last)
X (setq m (car lis))
X (cond ((atom m) (return nil))
X ((top-levels-eq data (car m))
X (setq *current-token* (1- *current-token*))
X (rplaca lis (cddr m))
X (return (car m))))
X (setq next m)
X loop (setq last next)
X (setq next (cddr next))
X (cond ((atom next) (return nil))
X ((top-levels-eq data (car next))
X (rplacd (cdr last) (cddr next))
X (setq *current-token* (1- *current-token*))
X (return (car next)))
X (t (go loop)))))
X
X(defun remove-old-no-num (lis data)
X (prog (m next last)
X (setq m (car lis))
X (cond ((atom m) (return nil))
X ((top-levels-eq data (car m))
X (setq *current-token* (1- *current-token*))
X (rplaca lis (cdr m))
X (return (car m))))
X (setq next m)
X loop (setq last next)
X (setq next (cdr next))
X (cond ((atom next) (return nil))
X ((top-levels-eq data (car next))
X (rplacd last (cdr next))
X (setq *current-token* (1- *current-token*))
X (return (car next)))
X (t (go loop)))))
X
X
X
X;;; Conflict Resolution
X;
X;
X; each conflict set element is a list of the following form:
X; ((p-name . data-part) (sorted wm-recency) special-case-number)
X
X(defun removecs (name data)
X (prog (cr-data inst cs)
X (setq cr-data (cons name data))
X (setq cs *conflict-set*)
X loop1 (cond ((null cs)
X (record-refract name data)
X (return nil)))
X (setq inst (car cs))
X (setq cs (cdr cs))
X (and (not (top-levels-eq (car inst) cr-data)) (go loop1))
X (setq *conflict-set* (delete inst *conflict-set* :test #'eq))))
X
X(defun insertcs (name data rating)
X (prog (instan)
X (and (refracted name data) (return nil))
X (setq instan (list (cons name data) (order-tags data) rating))
X (and (atom *conflict-set*) (setq *conflict-set* nil))
X (return (setq *conflict-set* (cons instan *conflict-set*)))))
X
X(defun order-tags (dat)
X (prog (tags)
X (setq tags nil)
X l1 (and (atom dat) (go l2))
X (setq tags (cons (creation-time (car dat)) tags))
X (setq dat (cdr dat))
X (go l1)
X l2 (cond ((eq *strategy* 'mea)
X (return (cons (car tags) (dsort (cdr tags)))))
X (t (return (dsort tags))))))
X
X; destructively sort x into descending order
X
X(defun dsort (x)
X (prog (sorted cur next cval nval)
X (and (atom (cdr x)) (return x))
X loop (setq sorted t)
X (setq cur x)
X (setq next (cdr x))
X chek (setq cval (car cur))
X (setq nval (car next))
X (cond ((> nval cval)
X (setq sorted nil)
X (rplaca cur nval)
X (rplaca next cval)))
X (setq cur next)
X (setq next (cdr cur))
X (cond ((not (null next)) (go chek))
X (sorted (return x))
X (t (go loop)))))
X
X(defun conflict-resolution nil
X (prog (best len)
X (setq len (length *conflict-set*))
X (cond ((> len *max-cs*) (setq *max-cs* len)))
X (setq *total-cs* (+ *total-cs* len))
X (cond (*conflict-set*
X (setq best (best-of *conflict-set*))
X (setq *conflict-set* (delete best *conflict-set* :test #'eq))
X (return (pname-instantiation best)))
X (t (return nil)))))
X
X(defun best-of (set) (best-of* (car set) (cdr set)))
X
X(defun best-of* (best rem)
X (cond ((not rem) best)
X ((conflict-set-compare best (car rem))
X (best-of* best (cdr rem)))
X (t (best-of* (car rem) (cdr rem)))))
X
X(defun remove-from-conflict-set (name)
X (prog (cs entry)
X l1 (setq cs *conflict-set*)
X l2 (cond ((atom cs) (return nil)))
X (setq entry (car cs))
X (setq cs (cdr cs))
X (cond ((eq name (caar entry))
X (setq *conflict-set* (delete entry *conflict-set* :test #'eq))
X (go l1))
X (t (go l2)))))
X
X(defun pname-instantiation (conflict-elem) (car conflict-elem))
X
X(defun order-part (conflict-elem) (cdr conflict-elem))
X
X(defun instantiation (conflict-elem)
X (cdr (pname-instantiation conflict-elem)))
X
X
X(defun conflict-set-compare (x y)
X (prog (x-order y-order xl yl xv yv)
X (setq x-order (order-part x))
X (setq y-order (order-part y))
X (setq xl (car x-order))
X (setq yl (car y-order))
X data (cond ((and (null xl) (null yl)) (go ps))
X ((null yl) (return t))
X ((null xl) (return nil)))
X (setq xv (car xl))
X (setq yv (car yl))
X (cond ((> xv yv) (return t))
X ((> yv xv) (return nil)))
X (setq xl (cdr xl))
X (setq yl (cdr yl))
X (go data)
X ps (setq xl (cdr x-order))
X (setq yl (cdr y-order))
X psl (cond ((null xl) (return t)))
X (setq xv (car xl))
X (setq yv (car yl))
X (cond ((> xv yv) (return t))
X ((> yv xv) (return nil)))
X (setq xl (cdr xl))
X (setq yl (cdr yl))
X (go psl)))
X
X
X(defun conflict-set nil
X (prog (cnts cs p z best)
X (setq cnts nil)
X (setq cs *conflict-set*)
X l1 (and (atom cs) (go l2))
X (setq p (caaar cs))
X (setq cs (cdr cs))
X (setq z (assoc p cnts :test #'eq))
X (cond ((null z) (setq cnts (cons (cons p 1.) cnts)))
X (t (rplacd z (1+ (cdr z)))))
X (go l1)
X l2 (cond ((atom cnts)
X (setq best (best-of *conflict-set*))
X (terpri)
X (return (list (caar best) 'dominates))))
X (terpri)
X (princ (caar cnts))
X (cond ((> (cdar cnts) 1.)
X (princ '| (|)
X (princ (cdar cnts))
X (princ '| occurrences)|)))
X (setq cnts (cdr cnts))
X (go l2)))
X
X
X
X;;; WM maintaining functions
X;
X; The order of operations in the following two functions is critical.
X; add-to-wm order: (1) change wm (2) record change (3) match
X; remove-from-wm order: (1) record change (2) match (3) change wm
X; (back will not restore state properly unless wm changes are recorded
X; before the cs changes that they cause) (match will give errors if
X; the thing matched is not in wm at the time)
X
X
X(defun add-to-wm (wme override)
X (prog (fa z part timetag port)
X (setq *critical* t)
X (setq *current-wm* (1+ *current-wm*))
X (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
X (setq *action-count* (1+ *action-count*))
X (setq fa (wm-hash wme))
X (or (member fa *wmpart-list* :test #'eq)
X (setq *wmpart-list* (cons fa *wmpart-list*)))
X (setq part (get fa 'wmpart*))
X (cond (override (setq timetag override))
X (t (setq timetag *action-count*)))
X (setq z (cons wme timetag))
X (putprop fa (cons z part) 'wmpart*)
X (record-change '=>wm *action-count* wme)
X (match 'new wme)
X (setq *critical* nil)
X (cond ((and *in-rhs* *wtrace*)
X (setq port (trace-file))
X (terpri port)
X (princ '|=>wm: | port)
X (ppelm wme port)))
X (and *in-rhs* *mtrace* (setq *madeby*
X (cons (cons wme *p-name*) *madeby*)))))
X
X; remove-from-wm uses eq, not equal to determine if wme is present
X
X(defun remove-from-wm (wme)
X (prog (fa z part timetag port)
X (setq fa (wm-hash wme))
X (setq part (get fa 'wmpart*))
X (setq z (assoc wme part :test #'eq))
X (or z (return nil))
X (setq timetag (cdr z))
X (cond ((and *wtrace* *in-rhs*)
X (setq port (trace-file))
X (terpri port)
X (princ '|<=wm: | port)
X (ppelm wme port)))
X (setq *action-count* (1+ *action-count*))
X (setq *critical* t)
X (setq *current-wm* (1- *current-wm*))
X (record-change '<=wm timetag wme)
X (match nil wme)
X (putprop fa (delete z part :test #'eq) 'wmpart* )
X (setq *critical* nil)))
X
X; mapwm maps down the elements of wm, applying fn to each element
X; each element is of form (datum . creation-time)
X
X(defun mapwm (fn)
X (prog (wmpl part)
X (setq wmpl *wmpart-list*)
X lab1 (cond ((atom wmpl) (return nil)))
X (setq part (get (car wmpl) 'wmpart*))
X (setq wmpl (cdr wmpl))
X (mapc fn part)
X (go lab1)))
X
X(defmacro wm (&rest a)
X `(progn
X (mapc (function (lambda (z) (terpri) (ppelm z t)))
X (get-wm ',a))
X nil) )
X
X(defun get-wm (z)
X (setq *wm-filter* z)
X (setq *wm* nil)
X (mapwm (function get-wm2))
X (prog2 nil *wm* (setq *wm* nil)))
X
X(defun get-wm2 (elem)
X (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*))
X (setq *wm* (cons (car elem) *wm*)))))
X
X(defun wm-hash (x)
X (cond ((not x) '<default>)
X ((not (car x)) (wm-hash (cdr x)))
X ((symbolp (car x)) (car x))
X (t (wm-hash (cdr x)))))
X
X(defun creation-time (wme)
X (cdr (assoc wme (get (wm-hash wme) 'wmpart*) :test #'eq)))
X
X(defun rehearse nil
X (prog nil
X (setq *old-wm* nil)
X (mapwm (function refresh-collect))
X (mapc (function refresh-del) *old-wm*)
X (mapc (function refresh-add) *old-wm*)
X (setq *old-wm* nil)))
X
X(defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*)))
X
X(defun refresh-del (x) (remove-from-wm (car x)))
X
X(defun refresh-add (x) (add-to-wm (car x) (cdr x)))
X
X(defun trace-file ()
X (prog (port)
X (setq port t)
X (cond (*trace-file*
X (setq port ($ofile *trace-file*))
X (cond ((null port)
X (%warn '|trace: file has been closed| *trace-file*)
X (setq port t)))))
X (return port)))
X
X
X;;; Basic functions for RHS evaluation
X
X(defun eval-rhs (pname data)
X (prog (node port)
X (cond (*ptrace*
X (setq port (trace-file))
X (terpri port)
X (princ *cycle-count* port)
X (princ '|. | port)
X (princ pname port)
X (time-tag-print data port)))
X (setq *data-matched* data)
X (setq *p-name* pname)
X (setq *last* nil)
X (setq node (get pname 'topnode))
X (init-var-mem (var-part node))
X (init-ce-var-mem (ce-var-part node))
X (begin-record pname data)
X (setq *in-rhs* t)
X (eval (rhs-part node))
X (setq *in-rhs* nil)
X (end-record)))
X
X(defun time-tag-print (data port)
X (cond ((not (null data))
X (time-tag-print (cdr data) port)
X (princ '| | port)
X (princ (creation-time (car data)) port))))
X
X(defun init-var-mem (vlist)
X (prog (v ind r)
X (setq *variable-memory* nil)
X top (and (atom vlist) (return nil))
X (setq v (car vlist))
X (setq ind (cadr vlist))
X (setq vlist (cddr vlist))
X (setq r (gelm *data-matched* ind))
X (setq *variable-memory* (cons (cons v r) *variable-memory*))
X (go top)))
X
X(defun init-ce-var-mem (vlist)
X (prog (v ind r)
X (setq *ce-variable-memory* nil)
X top (and (atom vlist) (return nil))
X (setq v (car vlist))
X (setq ind (cadr vlist))
X (setq vlist (cddr vlist))
X (setq r (ce-gelm *data-matched* ind))
X (setq *ce-variable-memory*
X (cons (cons v r) *ce-variable-memory*))
X (go top)))
X
X(defun make-ce-var-bind (var elem)
X (setq *ce-variable-memory*
X (cons (cons var elem) *ce-variable-memory*)))
X
X(defun make-var-bind (var elem)
X (setq *variable-memory* (cons (cons var elem) *variable-memory*)))
X
X(defun $varbind (x)
X (prog (r)
X (and (not *in-rhs*) (return x))
X (setq r (assoc x *variable-memory* :test #'eq))
X (cond (r (return (cdr r)))
X (t (return x)))))
X
X(defun get-ce-var-bind (x)
X (prog (r)
X (cond ((numberp x) (return (get-num-ce x))))
X (setq r (assoc x *ce-variable-memory* :test #'eq))
X (cond (r (return (cdr r)))
X (t (return nil)))))
X
X(defun get-num-ce (x)
X (prog (r l d)
X (setq r *data-matched*)
X (setq l (length r))
X (setq d (- l x))
X (and (> 0. d) (return nil))
X la (cond ((null r) (return nil))
X ((> 1. d) (return (car r))))
X (setq d (1- d))
X (setq r (cdr r))
X (go la)))
X
X
X(defun build-collect (z)
X (prog (r)
X la (and (atom z) (return nil))
X (setq r (car z))
X (setq z (cdr z))
X (cond ((and r (listp r))
X ($value '\()
X (build-collect r)
X ($value '\)))
X ((eq r '\\) ($change (car z)) (setq z (cdr z)))
X (t ($value r)))
X (go la)))
X
X(defun unflat (x) (setq *rest* x) (unflat*))
X
X(defun unflat* nil
X (prog (c)
X (cond ((atom *rest*) (return nil)))
X (setq c (car *rest*))
X (setq *rest* (cdr *rest*))
X (cond ((eq c '\() (return (cons (unflat*) (unflat*))))
X ((eq c '\)) (return nil))
X (t (return (cons c (unflat*)))))))
X
X
X(defun $change (x)
X (prog nil
X (cond ((and x (listp x)) (eval-function x)) ;modified to check for nil
X (t ($value ($varbind x))))))
X
X(defun eval-args (z)
X (prog (r)
X (rhs-tab 1.)
X la (and (atom z) (return nil))
X (setq r (car z))
X (setq z (cdr z))
X (cond ((eq r #\^)
X (rhs-tab (car z))
X (setq r (cadr z))
X (setq z (cddr z))))
X (cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
X (t ($change r)))
X (go la)))
X
X
X(defun eval-function (form)
X (cond ((not *in-rhs*)
X (%warn '|functions cannot be used at top level| (car form)))
X (t (eval form))))
X
X
X;;; Functions to manipulate the result array
X
X
X(defun $reset nil
X (setq *max-index* 0)
X (setq *next-index* 1))
X
X; rhs-tab implements the tab ('^') function in the rhs. it has
X; four responsibilities:
X; - to move the array pointers
X; - to watch for tabbing off the left end of the array
X; (ie, to watch for pointers less than 1)
X; - to watch for tabbing off the right end of the array
X; - to write nil in all the slots that are skipped
X; the last is necessary if the result array is not to be cleared
X; after each use; if rhs-tab did not do this, $reset
X; would be much slower.
X
X(defun rhs-tab (z) ($tab ($varbind z)))
X
X(defun $tab (z)
X (prog (edge next)
X (setq next ($litbind z))
X (and (floatp next) (setq next (round next)))
X (cond ((or (not (numberp next))
X (> next *size-result-array*)
X (> 1. next))
X (%warn '|illegal index after ^| next)
X (return *next-index*)))
X (setq edge (- next 1.))
X (cond ((> *max-index* edge) (go ok)))
X clear (cond ((== *max-index* edge) (go ok)))
X (putvector *result-array* edge nil)
X (setq edge (1- edge))
X (go clear)
X ok (setq *next-index* next)
X (return next)))
X
X(defun $value (v)
X (cond ((> *next-index* *size-result-array*)
X (%warn '|index too large| *next-index*))
X (t
X (and (> *next-index* *max-index*)
X (setq *max-index* *next-index*))
X (putvector *result-array* *next-index* v)
X (setq *next-index* (1+ *next-index*)))))
X
X(defun use-result-array nil
X (prog (k r)
X (setq k *max-index*)
X (setq r nil)
X top (and (== k 0.) (return r))
X (setq r (cons (getvector *result-array* k) r))
X (setq k (1- k))
X (go top)))
X
X(defun $assert nil
X (setq *last* (use-result-array))
X (add-to-wm *last* nil))
X
X(defun $parametercount nil *max-index*)
X
X(defun $parameter (k)
X (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
X (%warn '|illegal parameter number | k)
X nil)
X ((> k *max-index*) nil)
X (t (getvector *result-array* k))))
X
X
X;;; RHS actions
X
X
X(defmacro make(&rest z)
X `(prog nil
X ($reset)
X (eval-args ',z)
X ($assert)))
X
X(defmacro modify (&rest z)
X `(prog (old args)
X (setq args ',z)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'modify)
X (return nil)))
X (setq old (get-ce-var-bind (car args)))
X (cond ((null old)
X (%warn '|modify: first argument must be an element variable|
X (car args))
X (return nil)))
X (remove-from-wm old)
X (setq args (cdr args))
X ($reset)
X copy (and (atom old) (go fin))
X ($change (car old))
X (setq old (cdr old))
X (go copy)
X fin (eval-args args)
X ($assert)))
X
X(defmacro bind (&rest z)
X `(prog (val)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'bind)
X (return nil)))
X (cond ((< (length z) 1.)
X (%warn '|bind: wrong number of arguments to| ',z)
X (return nil))
X ((not (symbolp (car ',z)))
X (%warn '|bind: illegal argument| (car ',z))
X (return nil))
X ((= (length ',z) 1.) (setq val (gensym)))
X (t ($reset)
X (eval-args (cdr ',z))
X (setq val ($parameter 1.))))
X (make-var-bind (car ',z) val)))
X
X(defmacro cbind (&rest z)
X `(cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'cbind))
X ((not (= (length ',z) 1.))
X (%warn '|cbind: wrong number of arguments| ',z))
X ((not (symbolp (car ',z)))
X (%warn '|cbind: illegal argument| (car ',z)))
X ((null *last*)
X (%warn '|cbind: nothing added yet| (car ',z)))
X (t (make-ce-var-bind (car ',z) *last*))))
X
X(defmacro oremove (&rest z)
X `(prog (old args)
X (setq args ',z)
X (and (not *in-rhs*)(return (top-level-remove args)))
X top (and (atom args) (return nil))
X (setq old (get-ce-var-bind (car args)))
X (cond ((null old)
X (%warn '|remove: argument not an element variable| (car args))
X (return nil)))
X (remove-from-wm old)
X (setq args (cdr args))
X (go top)))
X
X(defmacro ocall (&rest z)
X `(prog (f)
X (setq f (car ',z))
X ($reset)
X (eval-args (cdr ',z))
X (funcall f)))
X
X(defmacro owrite (&rest z)
X `(prog (port max k x needspace)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'write)
X (return nil)))
X ($reset)
X (eval-args ',z)
X (setq k 1.)
X (setq max ($parametercount))
X (cond ((< max 1.)
X (%warn '|write: nothing to print| ',z)
X (return nil)))
X (setq port (default-write-file))
X (setq x ($parameter 1.))
X (cond ((and (symbolp x) ($ofile x))
X (setq port ($ofile x))
X (setq k 2.)))
X (setq needspace t)
X la (and (> k max) (return nil))
X (setq x ($parameter k))
X (cond ((eq x '|=== C R L F ===|)
X (setq needspace nil)
X (terpri port))
X ((eq x '|=== R J U S T ===|)
X (setq k (+ 2 k))
X (do-rjust ($parameter (1- k)) ($parameter k) port))
X ((eq x '|=== T A B T O ===|)
X (setq needspace nil)
X (setq k (1+ k))
X (do-tabto ($parameter k) port))
X (t
X (and needspace (princ '| | port))
X (setq needspace t)
X (princ x port)))
X (setq k (1+ k))
X (go la)))
X
X(defun default-write-file ()
X (prog (port)
X (setq port t)
X (cond (*write-file*
X (setq port ($ofile *write-file*))
X (cond ((null port)
X (%warn '|write: file has been closed| *write-file*)
X (setq port t)))))
X (return port)))
X
X
X(defun do-rjust (width value port)
X (prog (size)
X (cond ((eq value '|=== T A B T O ===|)
X (%warn '|rjust cannot precede this function| 'tabto)
X (return nil))
X ((eq value '|=== C R L F ===|)
X (%warn '|rjust cannot precede this function| 'crlf)
X (return nil))
X ((eq value '|=== R J U S T ===|)
X (%warn '|rjust cannot precede this function| 'rjust)
X (return nil)))
X (setq size (length (princ-to-string value )))
X (cond ((> size width)
X (princ '| | port)
X (princ value port)
X (return nil)))
X (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
X (princ value port)))
X
X(defun do-tabto (col port)
X (eval `(format ,port (concatenate 'string "~" (princ-to-string ,col) "T"))))
X
X; (prog (pos)
X; (setq pos (1+ (nwritn port)))
X; (cond ((> pos col)
X; (terpri port)
X; (setq pos 1)))
X; (do k (- col pos) (1- k) (not (> k 0)) (princ '| | port))
X; (return nil)))
X
X
X(defun halt nil
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'halt))
X (t (setq *halt-flag* t))))
X
X(defmacro build (&rest z)
X `(prog (r)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'build)
X (return nil)))
X ($reset)
X (build-collect ',z)
X (setq r (unflat (use-result-array)))
X (and *build-trace* (funcall *build-trace* r))
X (compile-production (car r) (cdr r))))
X
X(defun infile(file)
X (open file :direction :input))
X
X(defun outfile(file)
X (open file :direction :output))
X
X(defmacro openfile (&rest z)
X `(prog (file mode id)
X ($reset)
X (eval-args ',z)
X (cond ((not (equal ($parametercount) 3.))
X (%warn '|openfile: wrong number of arguments| ',z)
X (return nil)))
X (setq id ($parameter 1))
X (setq file ($parameter 2))
X (setq mode ($parameter 3))
X (cond ((not (symbolp id))
X (%warn '|openfile: file id must be a symbolic atom| id)
X (return nil))
X ((null id)
X (%warn '|openfile: 'nil' is reserved for the terminal| nil)
X (return nil))
X ((or ($ifile id)($ofile id))
X (%warn '|openfile: name already in use| id)
X (return nil)))
X (cond ((eq mode 'in) (putprop id (infile file) 'inputfile))
X ((eq mode 'out) (putprop id (outfile file) 'outputfile))
X (t (%warn '|openfile: illegal mode| mode)
X (return nil)))
X (return nil)))
X
X(defun $ifile (x)
X (cond ((and x (symbolp x)) (get x 'inputfile))
X (t *standard-input*)))
X
X(defun $ofile (x)
X (cond ((and x (symbolp x)) (get x 'outputfile))
X (t *standard-output*)))
X
X
X(defmacro closefile (&rest z)
X `(progn
X ($reset)
X (eval-args ',z)
X (mapc (function closefile2) (use-result-array))))
X
X(defun closefile2 (file)
X (prog (port)
X (cond ((not (symbolp file))
X (%warn '|closefile: illegal file identifier| file))
X ((setq port ($ifile file))
X (close port)
X (remprop file 'inputfile))
X ((setq port ($ofile file))
X (close port)
X (remprop file 'outputfile)))
X (return nil)))
X
X(defmacro default (&rest z)
X `(prog (file use)
X ($reset)
X (eval-args ',z)
X (cond ((not (equal ($parametercount) 2.))
X (%warn '|default: wrong number of arguments| ',z)
X (return nil)))
X (setq file ($parameter 1))
X (setq use ($parameter 2))
X (cond ((not (symbolp file))
X (%warn '|default: illegal file identifier| file)
X (return nil))
X ((not (member use '(write accept trace)))
X (%warn '|default: illegal use for a file| use)
X (return nil))
X ((and (member use '(write trace))
X (not (null file))
X (not ($ofile file)))
X (%warn '|default: file has not been opened for output| file)
X (return nil))
X ((and (eq use 'accept)
X (not (null file))
X (not ($ifile file)))
X (%warn '|default: file has not been opened for input| file)
X (return nil))
X ((eq use 'write) (setq *write-file* file))
X ((eq use 'accept) (setq *accept-file* file))
X ((eq use 'trace) (setq *trace-file* file)))
X (return nil)))
X
X
X
X;;; RHS Functions
X
X(defmacro accept (&rest z)
X `(prog (port arg)
X (cond ((> (length ',z) 1.)
X (%warn '|accept: wrong number of arguments| ',z)
X (return nil)))
X (setq port t)
X (cond (*accept-file*
X (setq port ($ifile *accept-file*))
X (cond ((null port)
X (%warn '|accept: file has been closed| *accept-file*)
X (return nil)))))
X (cond ((= (length ',z) 1)
X (setq arg ($varbind (car ',z)))
X (cond ((not (symbolp arg))
X (%warn '|accept: illegal file name| arg)
X (return nil)))
X (setq port ($ifile arg))
X (cond ((null port)
X (%warn '|accept: file not open for input| arg)
X (return nil)))))
X (cond ((= (tyipeek port) -1.)
X ($value 'end-of-file)
X (return nil)))
X (flat-value (read port))))
X
X(defun flat-value (x)
X (cond ((atom x) ($value x))
X (t (mapc (function flat-value) x))))
X
X(defun span-chars (x prt)
X (do ((ch (tyipeek prt) (tyipeek prt))) ((not (member ch x #'char-equal))) (read-char prt)))
X
X(defmacro acceptline (&rest z)
X `(prog ( def arg port)
X (setq port t)
X (setq def ',z)
X (cond (*accept-file*
X (setq port ($ifile *accept-file*))
X (cond ((null port)
X (%warn '|acceptline: file has been closed|
X *accept-file*)
X (return nil)))))
X (cond ((> (length def) 0)
X (setq arg ($varbind (car def)))
X (cond ((and (symbolp arg) ($ifile arg))
X (setq port ($ifile arg))
X (setq def (cdr def))))))
X (span-chars '(9. 41.) port)
X (cond ((member (tyipeek port) '(-1. 10.))
X (mapc (function $change) def)
X (return nil)))
X lp1 (flat-value (read port))
X (span-chars '(9. 41.) port)
X (cond ((not (member (tyipeek port) '(-1. 10.))) (go lp1)))))
X
X(defmacro substr (&rest l)
X `(prog (k elm start end)
X (cond ((not (= (length ',l) 3.))
X (%warn '|substr: wrong number of arguments| ',l)
--
---------------
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-9400turner@imagen.UUCP (D'arc Angel) (01/19/87)
X (return nil)))
X (setq elm (get-ce-var-bind (car ',l)))
X (cond ((null elm)
X (%warn '|first argument to substr must be a ce var|
X ',l)
X (return nil)))
X (setq start ($varbind (cadr ',l)))
X (setq start ($litbind start))
X (cond ((not (numberp start))
X (%warn '|second argument to substr must be a number|
X ',l)
X (return nil)))
X ;if a variable is bound to INF, the following
X ;will get the binding and treat it as INF is
X ;always treated. that may not be good
X (setq end ($varbind (caddr ',l)))
X (cond ((eq end 'inf) (setq end (length elm))))
X (setq end ($litbind end))
X (cond ((not (numberp end))
X (%warn '|third argument to substr must be a number|
X ',l)
X (return nil)))
X ;this loop does not check for the end of elm
X ;instead it relies on cdr of nil being nil
X ;this may not work in all versions of lisp
X (setq k 1.)
X la (cond ((> k end) (return nil))
X ((not (< k start)) ($value (car elm))))
X (setq elm (cdr elm))
X (setq k (1+ k))
X (go la)))
X
X
X(defmacro compute (&rest z) `($value (ari ',z)))
X
X; arith is the obsolete form of compute
X(defmacro arith (&rest z) `($value (ari ',z)))
X
X(defun ari (x)
X (cond ((atom x)
X (%warn '|bad syntax in arithmetic expression | x)
X 0.)
X ((atom (cdr x)) (ari-unit (car x)))
X ((eq (cadr x) '+)
X (+ (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '-)
X (difference (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '*)
X (times (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '//)
X (/ (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '\\)
X (mod (round (ari-unit (car x))) (round (ari (cddr x)))))
X (t (%warn '|bad syntax in arithmetic expression | x) 0.)))
X
X(defun ari-unit (a)
X (prog (r)
X (cond ((listp a) (setq r (ari a)))
X (t (setq r ($varbind a))))
X (cond ((not (numberp r))
X (%warn '|bad value in arithmetic expression| a)
X (return 0.))
X (t (return r)))))
X
X(defun genatom nil ($value (gensym)))
X
X(defmacro litval (&rest z)
X `(prog (r)
X (cond ((not (= (length ',z) 1.))
X (%warn '|litval: wrong number of arguments| ',z)
X ($value 0)
X (return nil))
X ((numberp (car ',z)) ($value (car ',z)) (return nil)))
X (setq r ($litbind ($varbind (car ',z))))
X (cond ((numberp r) ($value r) (return nil)))
X (%warn '|litval: argument has no literal binding| (car ',z))
X ($value 0)))
X
X
X(defmacro rjust (&rest z)
X `(prog (val)
X (cond ((not (= (length ',z) 1.))
X (%warn '|rjust: wrong number of arguments| ',z)
X (return nil)))
X (setq val ($varbind (car ',z)))
X (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
X (%warn '|rjust: illegal value for field width| val)
X (return nil)))
X ($value '|=== R J U S T ===|)
X ($value val)))
X
X
X(defmacro crlf()
X ($value '|=== C R L F ===|))
X
X(defmacro tabto (&rest z)
X `(prog (val)
X (cond ((not (= (length ',z) 1.))
X (%warn '|tabto: wrong number of arguments| ',z)
X (return nil)))
X (setq val ($varbind (car ',z)))
X (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
X (%warn '|tabto: illegal column number| ',z)
X (return nil)))
X ($value '|=== T A B T O ===|)
X ($value val)))
X
X
X
X;;; Printing WM
X
X(defmacro ppwm (&rest z)
X `(prog (next a avlist)
X (setq avlist ',z)
X (setq *filters* nil)
X (setq next 1.)
X l (and (atom avlist) (go print))
X (setq a (car avlist))
X (setq avlist (cdr avlist))
X (cond ((eq a #\^)
X (setq next (car avlist))
X (setq avlist (cdr avlist))
X (setq next ($litbind next))
X (and (floatp next) (setq next (round next)))
X (cond ((or (not (numberp next))
X (> next *size-result-array*)
X (> 1. next))
X (%warn '|illegal index after ^| next)
X (return nil))))
X ((variablep a)
X (%warn '|ppwm does not take variables| a)
X (return nil))
X (t (setq *filters* (cons next (cons a *filters*)))
X (setq next (1+ next))))
X (go l)
X print (mapwm (function ppwm2))
X (terpri)
X (return nil)))
X
X(defun ppwm2 (elm-tag)
X (cond ((filter (car elm-tag)) (terpri) (ppelm (car elm-tag) t))))
X
X(defun filter (elm)
X (prog (fl indx val)
X (setq fl *filters*)
X top (and (atom fl) (return t))
X (setq indx (car fl))
X (setq val (cadr fl))
X (setq fl (cddr fl))
X (and (ident (nth (1- indx) elm) val) (go top))
X (return nil)))
X
X(defun ident (x y)
X (cond ((eq x y) t)
X ((not (numberp x)) nil)
X ((not (numberp y)) nil)
X ((=alg x y) t)
X (t nil)))
X
X; the new ppelm is designed especially to handle literalize format
X; however, it will do as well as the old ppelm on other formats
X
X(defun ppelm (elm port)
X (prog (ppdat sep val att mode lastpos)
X (princ (creation-time elm) port)
X (princ '|: | port)
X (setq mode 'vector)
X (setq ppdat (get (car elm) 'ppdat))
X (and ppdat (setq mode 'a-v))
X (setq sep '|(|)
X (setq lastpos 0)
X (do
X ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
X ((atom vlist) nil)
X (setq val (car vlist))
X (setq att (assoc curpos ppdat))
X (cond (att (setq att (cdr att)))
X (t (setq att curpos)))
X (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
X (cond ((or (not (null val)) (eq mode 'vector))
X (princ sep port)
X (ppval val att lastpos port)
X (setq sep '| |)
X (setq lastpos curpos))))
X (princ '|)| port)))
X
X(defun ppval (val att lastpos port)
X (cond ((not (equal att (1+ lastpos)))
X (princ '^ port)
X (princ att port)
X (princ '| | port)))
X (princ val port))
X
X
X
X;;; printing production memory
X
X(defmacro pm (&rest z) `(progn (mapc #'pprule ',z) (terpri) nil))
X
X;Major modification here, because Common Lisp doesn't have a standard method
X;for determining the column position of the cursor. So we have to keep count.
X;So colprinc records the current column number and prints the symbol.
X
X(proclaim '(special *current-col*))
X(setq *current-col* 0)
X
X(defun nflatc(x)
X (length (princ-to-string x)))
X
X(defun colprinc(x)
X (setq *current-col* (+ *current-col* (nflatc x)))
X (princ x))
X
X(defun pprule (name)
X (prog (matrix next lab)
X (terpri)
X (setq *current-col* 0)
X (and (not (symbolp name)) (return nil))
X (setq matrix (get name 'production))
X (and (null matrix) (return nil))
X (terpri)
X (colprinc '|(p |)
X (colprinc name)
X top (and (atom matrix) (go fin))
X (setq next (car matrix))
X (setq matrix (cdr matrix))
X (setq lab nil)
X (terpri)
X (cond ((eq next '-)
X (colprinc '| - |)
X (setq next (car matrix))
X (setq matrix (cdr matrix)))
X ((eq next '-->)
X (colprinc '| |))
X ((and (eq next '{) (atom (car matrix)))
X (colprinc '| {|)
X (setq lab (car matrix))
X (setq next (cadr matrix))
X (setq matrix (cdddr matrix)))
X ((eq next '{)
X (colprinc '| {|)
X (setq lab (cadr matrix))
X (setq next (car matrix))
X (setq matrix (cdddr matrix)))
X (t (colprinc '| |)))
X (ppline next)
X (cond (lab (colprinc '| |) (colprinc lab) (colprinc '})))
X (go top)
X fin (colprinc '|)|)))
X
X(defun ppline (line)
X (prog ()
X (cond ((atom line) (colprinc line))
X ((equalp (symbol-name (car line)) "DISPLACED") ;don't print expanded macros
X (ppline (cadr line)))
X (t
X (colprinc '|(|)
X (setq *ppline* line)
X (ppline2)
X (colprinc '|)|)))
X (return nil)))
X
X(defun ppline2 ()
X (prog (needspace)
X (setq needspace nil)
X top (and (atom *ppline*) (return nil))
X (and needspace (colprinc '| |))
X (cond ((eq (car *ppline*) #\^) (ppattval))
X (t (pponlyval)))
X (setq needspace t)
X (go top)))
X
X;NWRITN, sort of.
X(defun nwritn(&optional port)
X (- 76 *current-col*))
X
X(defun ppattval ()
X (prog (att val)
X (setq att (cadr *ppline*))
X (setq *ppline* (cddr *ppline*))
X (setq val (getval))
X (cond ((> (+ (nwritn) (nflatc att) (nflatc val)) 76.)
X (terpri)
X (colprinc '| |)))
X (colprinc '^)
X (colprinc att)
X (mapc (function (lambda (z) (colprinc '| |) (colprinc z))) val)))
X
X(defun pponlyval ()
X (prog (val needspace)
X (setq val (getval))
X (setq needspace nil)
X (cond ((> (+ (nwritn) (nflatc val)) 76.)
X (setq needspace nil)
X (terpri)
X (colprinc '| |)))
X top (and (atom val) (return nil))
X (and needspace (colprinc '| |))
X (setq needspace t)
X (colprinc (car val))
X (setq val (cdr val))
X (go top)))
X
X(defun getval ()
X (prog (res v1)
X (setq v1 (car *ppline*))
X (setq *ppline* (cdr *ppline*))
X (cond ((member v1 '(= <> < <= => > <=>) :test #'eq)
X (setq res (cons v1 (getval))))
X ((eq v1 '{)
X (setq res (cons v1 (getupto '}))))
X ((eq v1 '<<)
X (setq res (cons v1 (getupto '>>))))
X ((eq v1 '//)
X (setq res (list v1 (car *ppline*)))
X (setq *ppline* (cdr *ppline*)))
X (t (setq res (list v1))))
X (return res)))
X
X(defun getupto (end)
X (prog (v)
X (and (atom *ppline*) (return nil))
X (setq v (car *ppline*))
X (setq *ppline* (cdr *ppline*))
X (cond ((eq v end) (return (list v)))
X (t (return (cons v (getupto end)))))))
X
X
X
X
X
X
X;;; backing up
X
X
X
X(defun record-index-plus (k)
X (setq *record-index* (+ k *record-index*))
X (cond ((< *record-index* 0.)
X (setq *record-index* *max-record-index*))
X ((> *record-index* *max-record-index*)
X (setq *record-index* 0.))))
X
X; the following routine initializes the record. putting nil in the
X; first slot indicates that that the record does not go back further
X; than that. (when the system backs up, it writes nil over the used
X; records so that it will recognize which records it has used. thus
X; the system is set up anyway never to back over a nil.)
X
X(defun initialize-record nil
X (setq *record-index* 0.)
X (setq *recording* nil)
X (setq *max-record-index* 31.)
X (putvector *record-array* 0. nil))
X
X; *max-record-index* holds the maximum legal index for record-array
X; so it and the following must be changed at the same time
X
X(defun begin-record (p data)
X (setq *recording* t)
X (setq *record* (list '=>refract p data)))
X
X(defun end-record nil
X (cond (*recording*
X (setq *record*
X (cons *cycle-count* (cons *p-name* *record*)))
X (record-index-plus 1.)
X (putvector *record-array* *record-index* *record*)
X (setq *record* nil)
X (setq *recording* nil))))
X
X(defun record-change (direct time elm)
X (cond (*recording*
X (setq *record*
X (cons direct (cons time (cons elm *record*)))))))
X
X; to maintain refraction information, need keep only one piece of information:
X; need to record all unsuccessful attempts to delete things from the conflict
X; set. unsuccessful deletes are caused by attempting to delete refracted
X; instantiations. when backing up, have to avoid putting things back into the
X; conflict set if they were not deleted when running forward
X
X(defun record-refract (rule data)
X (and *recording*
X (setq *record* (cons '<=refract (cons rule (cons data *record*))))))
X
X(defun refracted (rule data)
X (prog (z)
X (and (null *refracts*) (return nil))
X (setq z (cons rule data))
X (return (member z *refracts*))))
X
X(defun back (k)
X (prog (r)
X l (and (< k 1.) (return nil))
X (setq r (getvector *record-array* *record-index*))
X (and (null r) (return '|nothing more stored|))
X (putvector *record-array* *record-index* nil)
X (record-index-plus -1.)
X (undo-record r)
X (setq k (1- k))
X (go l)))
X
X(defun undo-record (r)
X (prog (save act a b rate)
X ;*recording* must be off during back up
X (setq save *recording*)
X (setq *refracts* nil)
X (setq *recording* nil)
X (and *ptrace* (back-print (list 'undo (car r) (cadr r))))
X (setq r (cddr r))
X top (and (atom r) (go fin))
X (setq act (car r))
X (setq a (cadr r))
X (setq b (caddr r))
X (setq r (cdddr r))
X (and *wtrace* (back-print (list 'undo act a)))
X (cond ((eq act '<=wm) (add-to-wm b a))
X ((eq act '=>wm) (remove-from-wm b))
X ((eq act '<=refract)
X (setq *refracts* (cons (cons a b) *refracts*)))
X ((and (eq act '=>refract) (still-present b))
X (setq *refracts* (delete (cons a b) *refracts*))
X (setq rate (rating-part (get a 'topnode)))
X (removecs a b)
X (insertcs a b rate))
X (t (%warn '|back: cannot undo action| (list act a))))
X (go top)
X fin (setq *recording* save)
X (setq *refracts* nil)
X (return nil)))
X
X; still-present makes sure that the user has not deleted something
X; from wm which occurs in the instantiation about to be restored; it
X; makes the check by determining whether each wme still has a time tag.
X
X(defun still-present (data)
X (prog nil
X l (cond ((atom data) (return t))
X ((creation-time (car data))
X (setq data (cdr data))
X (go l))
X (t (return nil)))))
X
X
X(defun back-print (x)
X (prog (port)
X (setq port (trace-file))
X (terpri port)
X (print x port)))
X
X
X
X
X;;; Functions to show how close rules are to firing
X
X(defmacro matches (&rest rule-list)
X `(progn
X (mapc (function matches2) ',rule-list)
X (terpri)) )
X
X(defun matches2 (p)
X (cond ((atom p)
X (terpri)
X (terpri)
X (princ p)
X (matches3 (get p 'backpointers) 2. (cons 1. nil)))))
X
X(defun matches3 (nodes ce part)
X (cond ((not (null nodes))
X (terpri)
X (princ '| ** matches for |)
X (princ part)
X (princ '| ** |)
X (mapc (function write-elms) (find-left-mem (car nodes)))
X (terpri)
X (princ '| ** matches for |)
X (princ (cons ce nil))
X (princ '| ** |)
X (mapc (function write-elms) (find-right-mem (car nodes)))
X (matches3 (cdr nodes) (1+ ce) (cons ce part)))))
X
X(defun write-elms (wme-or-count)
X (cond ((listp wme-or-count)
X (terpri)
X (mapc (function write-elms2) wme-or-count))))
X
X(defun write-elms2 (x)
X (princ '| |)
X (princ (creation-time x)))
X
X(defun find-left-mem (node)
X (cond ((eq (car node) '&and) (memory-part (caddr node)))
X (t (car (caddr node)))))
X
X(defun find-right-mem (node) (memory-part (cadddr node)))
X
X
X;;; Check the RHSs of productions
X
X
X(defun check-rhs (rhs) (mapc (function check-action) rhs))
X
X(defun check-action (x)
X (prog (a)
X (cond ((atom x)
X (%warn '|atomic action| x)
X (return nil)))
X (setq a (car x))
X (cond ((eq a 'bind) (check-bind x))
X ((eq a 'cbind) (check-cbind x))
X ((eq a 'make) (check-make x))
X ((eq a 'modify) (check-modify x))
X ((eq a 'oremove) (check-remove x))
X ((eq a 'owrite) (check-write x))
X ((eq a 'ocall) (check-call x))
X ((eq a 'halt) (check-halt x))
X ((eq a 'openfile) (check-openfile x))
X ((eq a 'closefile) (check-closefile x))
X ((eq a 'default) (check-default x))
X ((eq a 'build) (check-build x))
X ;;the following section is responsible for replacing standard ops RHS actions
X ;;with actions which don't conflict with existing CL functions. The RPLACA function
X ;;is used so that the change will be reflected in the production body.
X ((eq a 'remove) (rplaca x 'oremove)
X (check-remove x))
X ((eq a 'write) (rplaca x 'owrite)
X (check-write x))
X ((eq a 'call) (rplaca x 'ocall)
X (check-call x))
X (t (%warn '|undefined rhs action| a)))))
X
X(defun check-build (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-build-collect (cdr z)))
X
X(defun check-build-collect (args)
X (prog (r)
X top (and (null args) (return nil))
X (setq r (car args))
X (setq args (cdr args))
X (cond ((listp r) (check-build-collect r))
X ((eq r '\\)
X (and (null args) (%warn '|nothing to evaluate| r))
X (check-rhs-value (car args))
X (setq args (cdr args))))
X (go top)))
X
X(defun check-remove (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (mapc (function check-rhs-ce-var) (cdr z)))
X
X(defun check-make (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-openfile (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-closefile (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-default (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-modify (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-rhs-ce-var (cadr z))
X (and (null (cddr z)) (%warn '|no changes to make| z))
X (check-change& (cddr z)))
X
X(defun check-write (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-call (z)
X (prog (f)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (setq f (cadr z))
X (and (variablep f)
X (%warn '|function name must be a constant| z))
X (or (symbolp f)
X (%warn '|function name must be a symbolic atom| f))
X (or (externalp f)
X (%warn '|function name not declared external| f))
X (check-change& (cddr z))))
X
X(defun check-halt (z)
X (or (null (cdr z)) (%warn '|does not take arguments| z)))
X
X(defun check-cbind (z)
X (prog (v)
X (or (= (length z) 2.) (%warn '|takes only one argument| z))
X (setq v (cadr z))
X (or (variablep v) (%warn '|takes variable as argument| z))
X (note-ce-variable v)))
X
X(defun check-bind (z)
X (prog (v)
X (or (> (length z) 1.) (%warn '|needs arguments| z))
X (setq v (cadr z))
X (or (variablep v) (%warn '|takes variable as argument| z))
X (note-variable v)
X (check-change& (cddr z))))
X
X
X(defun check-change& (z)
X (prog (r tab-flag)
X (setq tab-flag nil)
X la (and (atom z) (return nil))
X (setq r (car z))
X (setq z (cdr z))
X (cond ((eq r #\^)
X (and tab-flag
X (%warn '|no value before this tab| (car z)))
X (setq tab-flag t)
X (check-tab-index (car z))
X (setq z (cdr z)))
X ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
X (t (setq tab-flag nil) (check-rhs-value r)))
X (go la)))
X
X(defun check-rhs-ce-var (v)
X (cond ((and (not (numberp v)) (not (ce-bound? v)))
X (%warn '|unbound element variable| v))
X ((and (numberp v) (or (< v 1.) (> v *ce-count*)))
X (%warn '|numeric element designator out of bounds| v))))
X
X(defun check-rhs-value (x)
X (cond ((and x (listp x)) (check-rhs-function x))
X (t (check-rhs-atomic x))))
X
X(defun check-rhs-atomic (x)
X (and (variablep x)
X (not (bound? x))
X (%warn '|unbound variable| x)))
X
X(defun check-rhs-function (x)
X (prog (a)
X (setq a (car x))
X (cond ((eq a 'compute) (check-compute x))
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 (member (cadr l) '(+ - * // \\) :test #'eq))
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 (member var *rhs-bound-vars* :test #'eq)
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 (member ce-var *rhs-bound-ce-vars* :test #'eq)
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 (+ (float *cycle-count*) 1.0e-20))
X (setq ac (+ (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 (/ (float *total-wm*) cc))
X 'mean 'working 'memory 'size
X (list *max-wm* 'maximum)))
X (terpri)
X (printlinec (list (round (/ (float *total-cs*) cc))
X 'mean 'conflict 'set 'size
X (list *max-cs* 'maximum)))
X (terpri)
X (printlinec (list (round (/ (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(defmacro excise (&rest z) `(mapc (function excise-p) ',z))
X
X(defmacro run (&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(defmacro external (&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 ((member rule *brkpts* :test #'eq) (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) (member rule *brkpts* :test #'eq))
X
X
XFRANZ.OPS
X
X; VPS2 -- Interpreter for OPS5
X;
X; Copyright (C) 1979, 1980, 1981
X; Charles L. Forgy, Pittsburgh, Pennsylvania
X
X
X
X; Users of this interpreter are requested to contact
X;
X; Charles Forgy
X; Computer Science Department
X; Carnegie-Mellon University
X; Pittsburgh, PA 15213
X; or
X; Forgy@CMUA
X;
X; so that they can be added to the mailing list for OPS5. The mailing list
X; is needed when new versions of the interpreter or manual are released.
X
X
X
X
X; Modifications added starting July, 1982 to make it easier to build
X; user environment - Ruven Brooks
X; ITT Integrated Systems Center
X; 1 Research Drive
X; Shelton, CT.
X
X;;; Definitions
X
X
X
X(declare (special *matrix* *feature-count* *pcount* *vars* *cur-vars*
X *curcond* *subnum* *last-node* *last-branch* *first-node*
X *sendtocall* *flag-part* *alpha-flag-part* *data-part*
X *alpha-data-part* *ce-vars* *virtual-cnt* *real-cnt*
X *current-token* *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
X *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
X *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
X *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
X *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
X *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
X *c60* *c61* *c62* *c63* *c64* *record-array* *result-array*
X *max-cs* *total-cs* *limit-cs* *cr-temp* *side*
X *conflict-set* *halt-flag* *phase* *critical*
X *cycle-count* *total-token* *max-token* *refracts*
X *limit-token* *total-wm* *current-wm* *max-wm*
X *action-count* *wmpart-list* *wm* *data-matched* *p-name*
X *variable-memory* *ce-variable-memory*
X *max-index* ; number of right-most field in wm element
X *next-index* *size-result-array* *rest* *build-trace* *last*
X *ptrace* *wtrace* *in-rhs* *recording* *accept-file* *trace-file*
X *mtrace* *madeby* ; used to trace and record makers of elements
X *write-file* *record-index* *max-record-index* *old-wm*
X *record* *filters* *break-flag* *strategy* *remaining-cycles*
X *wm-filter* *rhs-bound-vars* *rhs-bound-ce-vars* *ppline*
X *ce-count* *brkpts* *class-list* *buckets* *action-type*
X *literals* ;stores literal definitions
X *pnames* ;stores production names
X *externals* ;tracks external declarations
X *vector-attributes* ;list of vector-attributes
X ))
X
X(declare (localf ce-gelm gelm peek-sublex sublex
X eval-nodelist sendto and-left and-right not-left not-right
X top-levels-eq add-token real-add-token remove-old
X remove-old-num remove-old-no-num removecs insertcs dsort
X best-of best-of* conflict-set-compare =alg ))
X
X
X;;; Functions that were revised so that they would compile efficiently
X
X
X;* The function == is machine dependent\!
X;* This function compares small integers for equality. It uses EQ
X;* so that it will be fast, and it will consequently not work on all
X;* Lisps. It works in Franz Lisp for integers in [-128, 127]
X
X(def == (macro (z) `(eq ,(cadr z) ,(caddr z))))
X
X; =ALG returns T if A and B are algebraicly equal.
X
X(defun =alg (a b) (zerop (difference a b)))
X
X(def fast-symeval
X (macro (z)
X `(cond ((eq ,(cadr z) '*c1*) *c1*)
X ((eq ,(cadr z) '*c2*) *c2*)
X ((eq ,(cadr z) '*c3*) *c3*)
X ((eq ,(cadr z) '*c4*) *c4*)
X ((eq ,(cadr z) '*c5*) *c5*)
X ((eq ,(cadr z) '*c6*) *c6*)
X ((eq ,(cadr z) '*c7*) *c7*)
X (t (eval ,(cadr z)))]
X
X; getvector and putvector are fast routines for using one-dimensional
X; arrays. these routines do no checking; they assume
X; 1. the array is a vector with 0 being the index of the first
X; element
X; 2. the vector holds arbitrary list values
X
X; Example call: (putvector array index value)
X
X(def putvector
X (macro (z)
X (list '*rplacx (caddr z) (cadr z) (cadddr z))]
X
X; Example call: (getvector name index)
X
X(def getvector
X (macro (z)
X (list 'cxr (caddr z) (cadr z))]
X
X(defun ce-gelm (x k)
X (prog nil
X loop (and (== k 1.) (return (car x)))
X (setq k (1- k))
X (setq x (cdr x))
X (go loop)))
X
X; The loops in gelm were unwound so that fewer calls on DIFFERENCE
X; would be needed
X
X(defun gelm (x k)
X (prog (ce sub)
X (setq ce (/ k 10000.))
X (setq sub (- k (* ce 10000.)))
X celoop (and (== ce 0.) (go ph2))
X (setq x (cdr x))
X (and (== ce 1.) (go ph2))
X (setq x (cdr x))
X (and (== ce 2.) (go ph2))
X (setq x (cdr x))
X (and (== ce 3.) (go ph2))
X (setq x (cdr x))
X (and (== ce 4.) (go ph2))
X (setq ce (- ce 4.))
X (go celoop)
X ph2 (setq x (car x))
X subloop (and (== sub 0.) (go finis))
X (setq x (cdr x))
X (and (== sub 1.) (go finis))
X (setq x (cdr x))
X (and (== sub 2.) (go finis))
X (setq x (cdr x))
X (and (== sub 3.) (go finis))
X (setq x (cdr x))
X (and (== sub 4.) (go finis))
X (setq x (cdr x))
X (and (== sub 5.) (go finis))
X (setq x (cdr x))
X (and (== sub 6.) (go finis))
X (setq x (cdr x))
X (and (== sub 7.) (go finis))
X (setq x (cdr x))
X (and (== sub 8.) (go finis))
X (setq sub (- sub 8.))
X (go subloop)
X finis (return (car x))))
X
X
X;;; Utility functions
X
X
X
X(defun printline (x) (mapc (function printline*) x))
X
X(defun printline* (y) (princ '| |) (print y))
X
X(defun printlinec (x) (mapc (function printlinec*) x))
X
X(defun printlinec* (y) (princ '| |) (princ y))
X
X; intersect two lists using eq for the equality test
X
X(defun interq (x y)
X (cond ((atom x) nil)
X ((memq (car x) y) (cons (car x) (interq (cdr x) y)))
X (t (interq (cdr x) y))))
X
X(defun enter (x ll)
X (and (not (member x ll)) (setq ll (cons x ll))))
X
X; later versions of Franz have this standard
X(defun neq (x y)
X (not (eq x y)))
X(defun i-g-v nil
X (prog (x)
X (sstatus translink t)
X (setsyntax '\{ 66.)
X (setsyntax '\} 66.)
X (setsyntax '^ 66.)
X (setq *buckets* 64.) ; OPS5 allows 64 named slots
X (setq *accept-file* nil)
X (setq *write-file* nil)
X (setq *trace-file* nil)
X (setq *class-list* nil)
X (setq *brkpts* nil)
X (setq *strategy* 'lex)
X (setq *in-rhs* nil)
X (setq *ptrace* t)
X (setq *wtrace* nil)
X (setq *mtrace* t) ; turn on made-by tracing
X (setq *madeby* nil) ; record makers of wm elements
X (setq *recording* nil)
X (setq *refracts* nil)
X (setq *real-cnt* (setq *virtual-cnt* 0.))
X (setq *max-cs* (setq *total-cs* 0.))
X (setq *limit-token* 1000000.)
X (setq *limit-cs* 1000000.)
X (setq *critical* nil)
X (setq *build-trace* nil)
X (setq *wmpart-list* nil)
X (setq *pnames* nil)
X (setq *literals* nil) ; records literal definitions
X (setq *externals* nil) ; records external definitions
X (setq *vector-attributes* nil) ;records vector attributes
X (setq *size-result-array* 127.)
X (setq *result-array* (*makhunk 6))
X (setq *record-array* (*makhunk 6))
X (setq x 0)
X (setq *pnames* nil) ; list of production names
X loop (putvector *result-array* x nil)
X (setq x (1+ x))
X (and (not (> x *size-result-array*)) (go loop))
X (make-bottom-node)
X (setq *pcount* 0.)
X (initialize-record)
X (setq *cycle-count* (setq *action-count* 0.))
X (setq *total-token*
X (setq *max-token* (setq *current-token* 0.)))
X (setq *total-cs* (setq *max-cs* 0.))
X (setq *total-wm* (setq *max-wm* (setq *current-wm* 0.)))
X (setq *conflict-set* nil)
X (setq *wmpart-list* nil)
X (setq *p-name* nil)
X (setq *remaining-cycles* 1000000)]
X
X; if the size of result-array changes, change the line in i-g-v which
X; sets the value of *size-result-array*
X
X(defun \%warn (what where)
X (prog nil
X (terpri)
X (princ '\?)
X (and *p-name* (princ *p-name*))
X (princ '|..|)
X (princ where)
X (princ '|..|)
X (princ what)
X (return where)))
X
X(defun %error (what where)
X (%warn what where)
X (throw '\!error\! \!error\!))
X
X(defun round (x) (fix (plus 0.5 x)))
X
X(defun top-levels-eq (la lb)
X (prog nil
X lx (cond ((eq la lb) (return t))
X ((null la) (return nil))
X ((null lb) (return nil))
X ((not (eq (car la) (car lb))) (return nil)))
X (setq la (cdr la))
X (setq lb (cdr lb))
X (go lx)))
X
X
X;;; LITERAL and LITERALIZE
X
X(defun literal fexpr (z)
X (prog (atm val old)
X top (and (atom z) (return 'bound))
X (or (eq (cadr z) '=) (return (%warn '|wrong format| z)))
X (setq atm (car z))
X (setq val (caddr z))
X (setq z (cdddr z))
X (cond ((not (numberp val))
X (%warn '|can bind only to numbers| val))
X ((or (not (symbolp atm)) (variablep atm))
X (%warn '|can bind only constant atoms| atm))
X ((and (setq old (literal-binding-of atm)) (not (equal old val)))
X (%warn '|attempt to rebind attribute| atm))
X (t (putprop atm val 'ops-bind)))
X (go top)))
X
X(defun literalize fexpr (l)
X (prog (class-name atts)
X (setq class-name (car l))
X (cond ((have-compiled-production)
X (%warn '|literalize called after p| class-name)
X (return nil))
X ((get class-name 'att-list)
X (%warn '|attempt to redefine class| class-name)
X (return nil)))
X (setq *class-list* (cons class-name *class-list*))
X (setq atts (remove-duplicates (cdr l)))
X (test-attribute-names atts)
X (mark-conflicts atts atts)
X (putprop class-name atts 'att-list)))
X
X(defun vector-attribute fexpr (l)
X (cond ((have-compiled-production)
X (%warn '|vector-attribute called after p| l))
X (t
X (test-attribute-names l)
X (mapc (function vector-attribute2) l))))
X
X(defun vector-attribute2 (att) (putprop att t 'vector-attribute)
X (setq *vector-attributes*
X (enter att *vector-attributes*)))
X
X(defun is-vector-attribute (att) (get att 'vector-attribute))
X
X(defun test-attribute-names (l)
X (mapc (function test-attribute-names2) l))
X
X(defun test-attribute-names2 (atm)
X (cond ((or (not (symbolp atm)) (variablep atm))
X (%warn '|can bind only constant atoms| atm))))
X
X(defun finish-literalize nil
X (cond ((not (null *class-list*))
X (mapc (function note-user-assigns) *class-list*)
X (mapc (function assign-scalars) *class-list*)
X (mapc (function assign-vectors) *class-list*)
X (mapc (function put-ppdat) *class-list*)
X (mapc (function erase-literal-info) *class-list*)
X (setq *class-list* nil)
X (setq *buckets* nil))))
X
X(defun have-compiled-production nil (not (zerop *pcount*)))
X
X(defun put-ppdat (class)
X (prog (al att ppdat)
X (setq ppdat nil)
X (setq al (get class 'att-list))
X top (cond ((not (atom al))
X (setq att (car al))
X (setq al (cdr al))
X (setq ppdat
X (cons (cons (literal-binding-of att) att)
X ppdat))
X (go top)))
X (putprop class ppdat 'ppdat)))
X
X; note-user-assigns and note-user-vector-assigns are needed only when
X; literal and literalize are both used in a program. They make sure that
X; the assignments that are made explicitly with literal do not cause problems
X; for the literalized classes.
X
X(defun note-user-assigns (class)
X (mapc (function note-user-assigns2) (get class 'att-list)))
X
X(defun note-user-assigns2 (att)
X (prog (num conf buck clash)
X (setq num (literal-binding-of att))
X (and (null num) (return nil))
X (setq conf (get att 'conflicts))
X (setq buck (store-binding att num))
X (setq clash (find-common-atom buck conf))
X (and clash
X (%warn '|attributes in a class assigned the same number|
X (cons att clash)))
X (return nil)))
X
X(defun note-user-vector-assigns (att given needed)
X (and (> needed given)
X (%warn '|vector attribute assigned too small a value in literal| att)))
X
X(defun assign-scalars (class)
X (mapc (function assign-scalars2) (get class 'att-list)))
X
X(defun assign-scalars2 (att)
X (prog (tlist num bucket conf)
X (and (literal-binding-of att) (return nil))
X (and (is-vector-attribute att) (return nil))
X (setq tlist (buckets))
X (setq conf (get att 'conflicts))
X top (cond ((atom tlist)
X (%warn '|could not generate a binding| att)
X (store-binding att -1.)
X (return nil)))
X (setq num (caar tlist))
X (setq bucket (cdar tlist))
X (setq tlist (cdr tlist))
X (cond ((disjoint bucket conf) (store-binding att num))
X (t (go top)))))
X
X(defun assign-vectors (class)
X (mapc (function assign-vectors2) (get class 'att-list)))
X
X(defun assign-vectors2 (att)
X (prog (big conf new old need)
X (and (not (is-vector-attribute att)) (return nil))
X (setq big 1.)
X (setq conf (get att 'conflicts))
X top (cond ((not (atom conf))
X (setq new (car conf))
X (setq conf (cdr conf))
X (cond ((is-vector-attribute new)
X (%warn '|class has two vector attributes|
X (list att new)))
X (t (setq big (max (literal-binding-of new) big))))
X (go top)))
X (setq need (1+ big))
X (setq old (literal-binding-of att))
X (cond (old (note-user-vector-assigns att old need))
X (t (store-binding att need)))
X (return nil)))
X
X(defun disjoint (la lb) (not (find-common-atom la lb)))
X
X(defun find-common-atom (la lb)
X (prog nil
X top (cond ((null la) (return nil))
X ((memq (car la) lb) (return (car la)))
X (t (setq la (cdr la)) (go top)))))
X
X(defun mark-conflicts (rem all)
X (cond ((not (null rem))
X (mark-conflicts2 (car rem) all)
X (mark-conflicts (cdr rem) all))))
X
X(defun mark-conflicts2 (atm lst)
X (prog (l)
X (setq l lst)
X top (and (atom l) (return nil))
X (conflict atm (car l))
X (setq l (cdr l))
X (go top)))
X
X(defun conflict (a b)
X (prog (old)
X (setq old (get a 'conflicts))
X (and (not (eq a b))
X (not (memq b old))
X (putprop a (cons b old) 'conflicts))))
X
X(defun remove-duplicates (lst)
X (cond ((atom lst) nil)
X ((memq (car lst) (cdr lst)) (remove-duplicates (cdr lst)))
X (t (cons (car lst) (remove-duplicates (cdr lst))))))
X
X(defun literal-binding-of (name) (get name 'ops-bind))
X
X(defun store-binding (name lit)
X (putprop name lit 'ops-bind)
X (add-bucket name lit))
X
X(defun add-bucket (name num)
X (prog (buc)
X (setq buc (assoc num (buckets)))
X (and (not (memq name buc))
X (rplacd buc (cons name (cdr buc))))
X (return buc)))
X
X(defun buckets nil
X (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
X *buckets*)
X
X(defun make-nums (k)
X (prog (nums)
X (setq nums nil)
X l (and (< k 2.) (return nums))
X (setq nums (cons (ncons k) nums))
X (setq k (1- k))
X (go l)))
X
X;(defun erase-literal-info (class)
X; (mapc (function erase-literal-info2) (get class 'att-list))
X; (remprop class 'att-list))
X
X; modified to record literal info in the variable *literals*
X(def erase-literal-info
X (lambda (class)
X (setq *literals*
X (cons (cons class (get class 'att-list)) *literals*))
X (mapc (function erase-literal-info2) (get class 'att-list))
X (remprop class 'att-list)))
X
X
X(defun erase-literal-info2 (att) (remprop att 'conflicts))
X
X
X;;; LHS Compiler
X
X(defun p fexpr (z)
X (finish-literalize)
X (princ '*)
X (drain)
X (compile-production (car z) (cdr z)))
X
X(defun compile-production (name matrix)
X (prog (erm)
X (setq *p-name* name)
X (setq erm (catch (cmp-p name matrix) \!error\!))
X ; following line is modified to save production name on *pnames*
X (and (null erm) (setq *pnames* (enter name *pnames*)))
X (setq *p-name* nil)
X (return erm)))
X
X(defun peek-lex nil (car *matrix*))
X
X(defun lex nil
X (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*))))
X
X(defun end-of-p nil (atom *matrix*))
X
X(defun rest-of-p nil *matrix*)
X
X(defun prepare-lex (prod) (setq *matrix* prod))
X
X
X(defun peek-sublex nil (car *curcond*))
X
X(defun sublex nil
X (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*))))
X
X(defun end-of-ce nil (atom *curcond*))
X
X(defun rest-of-ce nil *curcond*)
X
X(defun prepare-sublex (ce) (setq *curcond* ce))
X
X(defun make-bottom-node nil (setq *first-node* (list '&bus nil)))
X
X(defun cmp-p (name matrix)
X (prog (m bakptrs)
X (cond ((or (null name) (dtpr name))
X (%error '|illegal production name| name))
X ((equal (get name 'production) matrix)
X (return nil)))
X (prepare-lex matrix)
X (excise-p name)
X (setq bakptrs nil)
X (setq *pcount* (1+ *pcount*))
X (setq *feature-count* 0.)
X (setq *ce-count* 0)
X (setq *vars* nil)
X (setq *ce-vars* nil)
X (setq *rhs-bound-vars* nil)
X (setq *rhs-bound-ce-vars* nil)
X (setq *last-branch* nil)
X (setq m (rest-of-p))
X l1 (and (end-of-p) (%error '|no '-->' in production| m))
X (cmp-prin)
X (setq bakptrs (cons *last-branch* bakptrs))
X (or (eq '--> (peek-lex)) (go l1))
X (lex)
X (check-rhs (rest-of-p))
X (link-new-node (list '&p
X *feature-count*
X name
X (encode-dope)
X (encode-ce-dope)
X (cons 'progn (rest-of-p))))
X (putprop name (cdr (nreverse bakptrs)) 'backpointers)
X (putprop name matrix 'production)
X (putprop name *last-node* 'topnode)))
X
X(defun rating-part (pnode) (cadr pnode))
X
X(defun var-part (pnode) (car (cdddr pnode)))
X
X(defun ce-var-part (pnode) (cadr (cdddr pnode)))
X
X(defun rhs-part (pnode) (caddr (cdddr pnode)))
X
X(defun excise-p (name)
X (cond ((and (symbolp name) (get name 'topnode))
X (printline (list name 'is 'excised))
--
---------------
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-9400turner@imagen.UUCP (D'arc Angel) (01/19/87)
X (setq *pcount* (1- *pcount*))
X (remove-from-conflict-set name)
X (kill-node (get name 'topnode))
X (setq *pnames* (delq name *pnames*))
X (remprop name 'production)
X (remprop name 'backpointers)
X (remprop name 'topnode))))
X
X(defun kill-node (node)
X (prog nil
X top (and (atom node) (return nil))
X (rplaca node '&old)
X (setq node (cdr node))
X (go top)))
X
X(defun cmp-prin nil
X (prog nil
X (setq *last-node* *first-node*)
X (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
X ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
X (t (cmp-posce) (cmp-and)))))
X
X(defun cmp-negce nil (lex) (cmp-ce))
X
X(defun cmp-posce nil
X (setq *ce-count* (1+ *ce-count*))
X (cond ((eq (peek-lex) '\{) (cmp-ce+cevar))
X (t (cmp-ce))))
X
X(defun cmp-ce+cevar nil
X (prog (z)
X (lex)
X (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
X (t (cmp-ce) (cmp-cevar)))
X (setq z (lex))
X (or (eq z '\}) (%error '|missing '}'| z))))
X
X(defun new-subnum (k)
X (or (numberp k) (%error '|tab must be a number| k))
X (setq *subnum* (fix k)))
X
X(defun incr-subnum nil (setq *subnum* (1+ *subnum*)))
X
X(defun cmp-ce nil
X (prog (z)
X (new-subnum 0.)
X (setq *cur-vars* nil)
X (setq z (lex))
X (and (atom z)
X (%error '|atomic conditions are not allowed| z))
X (prepare-sublex z)
X la (and (end-of-ce) (return nil))
X (incr-subnum)
X (cmp-element)
X (go la)))
X
X(defun cmp-element nil
X (and (eq (peek-sublex) '^) (cmp-tab))
X (cond ((eq (peek-sublex) '\{) (cmp-product))
X (t (cmp-atomic-or-any))))
X
X(defun cmp-atomic-or-any nil
X (cond ((eq (peek-sublex) '<<) (cmp-any))
X (t (cmp-atomic))))
X
X(defun cmp-any nil
X (prog (a z)
X (sublex)
X (setq z nil)
X la (cond ((end-of-ce) (%error '|missing '>>'| a)))
X (setq a (sublex))
X (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
X (link-new-node (list '&any nil (current-field) z))))
X
X
X(defun cmp-tab nil
X (prog (r)
X (sublex)
X (setq r (sublex))
X (setq r ($litbind r))
X (new-subnum r)))
X
X(defun $litbind (x)
X (prog (r)
X (cond ((and (symbolp x) (setq r (literal-binding-of x)))
X (return r))
X (t (return x)))))
X
X(defun get-bind (x)
X (prog (r)
X (cond ((and (symbolp x) (setq r (literal-binding-of x)))
X (return r))
X (t (return nil)))))
X
X(defun cmp-atomic nil
X (prog (test x)
X (setq x (peek-sublex))
X (cond ((eq x '=) (setq test 'eq) (sublex))
X ((eq x '<>) (setq test 'ne) (sublex))
X ((eq x '<) (setq test 'lt) (sublex))
X ((eq x '<=) (setq test 'le) (sublex))
X ((eq x '>) (setq test 'gt) (sublex))
X ((eq x '>=) (setq test 'ge) (sublex))
X ((eq x '<=>) (setq test 'xx) (sublex))
X (t (setq test 'eq)))
X (cmp-symbol test)))
X
X(defun cmp-product nil
X (prog (save)
X (setq save (rest-of-ce))
X (sublex)
X la (cond ((end-of-ce)
X (cond ((member '\} save)
X (%error '|wrong contex for '}'| save))
X (t (%error '|missing '}'| save))))
X ((eq (peek-sublex) '\}) (sublex) (return nil)))
X (cmp-atomic-or-any)
X (go la)))
X
X(defun variablep (x) (and (symbolp x) (eq (getchar x 1.) '<)))
X
X(defun cmp-symbol (test)
X (prog (flag)
X (setq flag t)
X (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
X (cond ((and flag (variablep (peek-sublex)))
X (cmp-var test))
X ((numberp (peek-sublex)) (cmp-number test))
X ((symbolp (peek-sublex)) (cmp-constant test))
X (t (%error '|unrecognized symbol| (sublex))))))
X
X(defun cmp-constant (test)
X (or (memq test '(eq ne xx))
X (%error '|non-numeric constant after numeric predicate| (sublex)))
X (link-new-node (list (concat 't test 'a)
X nil
X (current-field)
X (sublex))))
X
X(defun cmp-number (test)
X (link-new-node (list (concat 't test 'n)
X nil
X (current-field)
X (sublex))))
X
X(defun current-field nil (field-name *subnum*))
X
X(defun field-name (num)
X (cond ((= num 1.) '*c1*)
X ((= num 2.) '*c2*)
X ((= num 3.) '*c3*)
X ((= num 4.) '*c4*)
X ((= num 5.) '*c5*)
X ((= num 6.) '*c6*)
X ((= num 7.) '*c7*)
X ((= num 8.) '*c8*)
X ((= num 9.) '*c9*)
X ((= num 10.) '*c10*)
X ((= num 11.) '*c11*)
X ((= num 12.) '*c12*)
X ((= num 13.) '*c13*)
X ((= num 14.) '*c14*)
X ((= num 15.) '*c15*)
X ((= num 16.) '*c16*)
X ((= num 17.) '*c17*)
X ((= num 18.) '*c18*)
X ((= num 19.) '*c19*)
X ((= num 20.) '*c20*)
X ((= num 21.) '*c21*)
X ((= num 22.) '*c22*)
X ((= num 23.) '*c23*)
X ((= num 24.) '*c24*)
X ((= num 25.) '*c25*)
X ((= num 26.) '*c26*)
X ((= num 27.) '*c27*)
X ((= num 28.) '*c28*)
X ((= num 29.) '*c29*)
X ((= num 30.) '*c30*)
X ((= num 31.) '*c31*)
X ((= num 32.) '*c32*)
X ((= num 33.) '*c33*)
X ((= num 34.) '*c34*)
X ((= num 35.) '*c35*)
X ((= num 36.) '*c36*)
X ((= num 37.) '*c37*)
X ((= num 38.) '*c38*)
X ((= num 39.) '*c39*)
X ((= num 40.) '*c40*)
X ((= num 41.) '*c41*)
X ((= num 42.) '*c42*)
X ((= num 43.) '*c43*)
X ((= num 44.) '*c44*)
X ((= num 45.) '*c45*)
X ((= num 46.) '*c46*)
X ((= num 47.) '*c47*)
X ((= num 48.) '*c48*)
X ((= num 49.) '*c49*)
X ((= num 50.) '*c50*)
X ((= num 51.) '*c51*)
X ((= num 52.) '*c52*)
X ((= num 53.) '*c53*)
X ((= num 54.) '*c54*)
X ((= num 55.) '*c55*)
X ((= num 56.) '*c56*)
X ((= num 57.) '*c57*)
X ((= num 58.) '*c58*)
X ((= num 59.) '*c59*)
X ((= num 60.) '*c60*)
X ((= num 61.) '*c61*)
X ((= num 62.) '*c62*)
X ((= num 63.) '*c63*)
X ((= num 64.) '*c64*)
X (t (%error '|condition is too long| (rest-of-ce)))))
X
X
X;;; Compiling variables
X;
X;
X;
X; *cur-vars* are the variables in the condition element currently
X; being compiled. *vars* are the variables in the earlier condition
X; elements. *ce-vars* are the condition element variables. note
X; that the interpreter will not confuse condition element and regular
X; variables even if they have the same name.
X;
X; *cur-vars* is a list of triples: (name predicate subelement-number)
X; eg: ( (<x> eq 3)
X; (<y> ne 1)
X; . . . )
X;
X; *vars* is a list of triples: (name ce-number subelement-number)
X; eg: ( (<x> 3 3)
X; (<y> 1 1)
X; . . . )
X;
X; *ce-vars* is a list of pairs: (name ce-number)
X; eg: ( (ce1 1)
X; (<c3> 3)
X; . . . )
X
X(defun var-dope (var) (assq var *vars*))
X
X(defun ce-var-dope (var) (assq var *ce-vars*))
X
X(defun cmp-var (test)
X (prog (old name)
X (setq name (sublex))
X (setq old (assq name *cur-vars*))
X (cond ((and old (eq (cadr old) 'eq))
X (cmp-old-eq-var test old))
X ((and old (eq test 'eq)) (cmp-new-eq-var name old))
X (t (cmp-new-var name test)))))
X
X(defun cmp-new-var (name test)
X (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*)))
X
X(defun cmp-old-eq-var (test old)
X (link-new-node (list (concat 't test 's)
X nil
X (current-field)
X (field-name (caddr old)))))
X
X(defun cmp-new-eq-var (name old)
X (prog (pred next)
X (setq *cur-vars* (delq old *cur-vars*))
X (setq next (assq name *cur-vars*))
X (cond (next (cmp-new-eq-var name next))
X (t (cmp-new-var name 'eq)))
X (setq pred (cadr old))
X (link-new-node (list (concat 't pred 's)
X nil
X (field-name (caddr old))
X (current-field)))))
X
X(defun cmp-cevar nil
X (prog (name old)
X (setq name (lex))
X (setq old (assq name *ce-vars*))
X (and old
X (%error '|condition element variable used twice| name))
X (setq *ce-vars* (cons (list name 0.) *ce-vars*))))
X
X(defun cmp-not nil (cmp-beta '¬))
X
X(defun cmp-nobeta nil (cmp-beta nil))
X
X(defun cmp-and nil (cmp-beta '&and))
X
X(defun cmp-beta (kind)
X (prog (tlist vdope vname vpred vpos old)
X (setq tlist nil)
X la (and (atom *cur-vars*) (go lb))
X (setq vdope (car *cur-vars*))
X (setq *cur-vars* (cdr *cur-vars*))
X (setq vname (car vdope))
X (setq vpred (cadr vdope))
X (setq vpos (caddr vdope))
X (setq old (assq vname *vars*))
X (cond (old (setq tlist (add-test tlist vdope old)))
X ((neq kind '¬) (promote-var vdope)))
X (go la)
X lb (and kind (build-beta kind tlist))
X (or (eq kind '¬) (fudge))
X (setq *last-branch* *last-node*)))
X
X(defun add-test (list new old)
X (prog (ttype lloc rloc)
X (setq *feature-count* (1+ *feature-count*))
X (setq ttype (concat 't (cadr new) 'b))
X (setq rloc (encode-singleton (caddr new)))
X (setq lloc (encode-pair (cadr old) (caddr old)))
X (return (cons ttype (cons lloc (cons rloc list))))))
X
X; the following two functions encode indices so that gelm can
X; decode them as fast as possible
X
X(defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b)))
X
X(defun encode-singleton (a) (1- a))
X
X(defun promote-var (dope)
X (prog (vname vpred vpos new)
X (setq vname (car dope))
X (setq vpred (cadr dope))
X (setq vpos (caddr dope))
X (or (eq 'eq vpred)
X (%error '|illegal predicate for first occurrence|
X (list vname vpred)))
X (setq new (list vname 0. vpos))
X (setq *vars* (cons new *vars*))))
X
X(defun fudge nil
X (mapc (function fudge*) *vars*)
X (mapc (function fudge*) *ce-vars*))
X
X(defun fudge* (z)
X (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a)))))
X
X(defun build-beta (type tests)
X (prog (rpred lpred lnode lef)
X (link-new-node (list '&mem nil nil (protomem)))
X (setq rpred *last-node*)
X (cond ((eq type '&and)
X (setq lnode (list '&mem nil nil (protomem))))
X (t (setq lnode (list '&two nil nil))))
X (setq lpred (link-to-branch lnode))
X (cond ((eq type '&and) (setq lef lpred))
X (t (setq lef (protomem))))
X (link-new-beta-node (list type nil lef rpred tests))))
X
X(defun protomem nil (list nil))
X
X(defun memory-part (mem-node) (car (cadddr mem-node)))
X
X(defun encode-dope nil
X (prog (r all z k)
X (setq r nil)
X (setq all *vars*)
X la (and (atom all) (return r))
X (setq z (car all))
X (setq all (cdr all))
X (setq k (encode-pair (cadr z) (caddr z)))
X (setq r (cons (car z) (cons k r)))
X (go la)))
X
X(defun encode-ce-dope nil
X (prog (r all z k)
X (setq r nil)
X (setq all *ce-vars*)
X la (and (atom all) (return r))
X (setq z (car all))
X (setq all (cdr all))
X (setq k (cadr z))
X (setq r (cons (car z) (cons k r)))
X (go la)))
X
X
X
X;;; Linking the nodes
X
X(defun link-new-node (r)
X (cond ((not (member (car r) '(&p &mem &two &and ¬)))
X (setq *feature-count* (1+ *feature-count*))))
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-node* (link-left *last-node* r)))
X
X(defun link-to-branch (r)
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-branch* (link-left *last-branch* r)))
X
X(defun link-new-beta-node (r)
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-node* (link-both *last-branch* *last-node* r))
X (setq *last-branch* *last-node*))
X
X(defun link-left (pred succ)
X (prog (a r)
X (setq a (left-outs pred))
X (setq r (find-equiv-node succ a))
X (and r (return r))
X (setq *real-cnt* (1+ *real-cnt*))
X (attach-left pred succ)
X (return succ)))
X
X(defun link-both (left right succ)
X (prog (a r)
X (setq a (interq (left-outs left) (right-outs right)))
X (setq r (find-equiv-beta-node succ a))
X (and r (return r))
X (setq *real-cnt* (1+ *real-cnt*))
X (attach-left left succ)
X (attach-right right succ)
X (return succ)))
X
X(defun attach-right (old new)
X (rplaca (cddr old) (cons new (caddr old))))
X
X(defun attach-left (old new)
X (rplaca (cdr old) (cons new (cadr old))))
X
X(defun right-outs (node) (caddr node))
X
X(defun left-outs (node) (cadr node))
X
X(defun find-equiv-node (node list)
X (prog (a)
X (setq a list)
X l1 (cond ((atom a) (return nil))
X ((equiv node (car a)) (return (car a))))
X (setq a (cdr a))
X (go l1)))
X
X(defun find-equiv-beta-node (node list)
X (prog (a)
X (setq a list)
X l1 (cond ((atom a) (return nil))
X ((beta-equiv node (car a)) (return (car a))))
X (setq a (cdr a))
X (go l1)))
X
X; do not look at the predecessor fields of beta nodes; they have to be
X; identical because of the way the candidate nodes were found
X
X(defun equiv (a b)
X (and (eq (car a) (car b))
X (or (eq (car a) '&mem)
X (eq (car a) '&two)
X (equal (caddr a) (caddr b)))
X (equal (cdddr a) (cdddr b))))
X
X(defun beta-equiv (a b)
X (and (eq (car a) (car b))
X (equal (cddddr a) (cddddr b))
X (or (eq (car a) '&and) (equal (caddr a) (caddr b)))))
X
X; the equivalence tests are set up to consider the contents of
X; node memories, so they are ready for the build action
X
X;;; Network interpreter
X
X(defun match (flag wme)
X (sendto flag (list wme) 'left (list *first-node*)))
X
X; note that eval-nodelist is not set up to handle building
X; productions. would have to add something like ops4's build-flag
X
X(defun eval-nodelist (nl)
X (prog nil
X top (and (not nl) (return nil))
X (setq *sendtocall* nil)
X (setq *last-node* (car nl))
X (apply (caar nl) (cdar nl))
X (setq nl (cdr nl))
X (go top)))
X
X(defun sendto (flag data side nl)
X (prog nil
X top (and (not nl) (return nil))
X (setq *side* side)
X (setq *flag-part* flag)
X (setq *data-part* data)
X (setq *sendtocall* t)
X (setq *last-node* (car nl))
X (apply (caar nl) (cdar nl))
X (setq nl (cdr nl))
X (go top)))
X
X; &bus sets up the registers for the one-input nodes. note that this
X(defun &bus (outs)
X (prog (dp)
X (setq *alpha-flag-part* *flag-part*)
X (setq *alpha-data-part* *data-part*)
X (setq dp (car *data-part*))
X (setq *c1* (car dp))
X (setq dp (cdr dp))
X (setq *c2* (car dp))
X (setq dp (cdr dp))
X (setq *c3* (car dp))
X (setq dp (cdr dp))
X (setq *c4* (car dp))
X (setq dp (cdr dp))
X (setq *c5* (car dp))
X (setq dp (cdr dp))
X (setq *c6* (car dp))
X (setq dp (cdr dp))
X (setq *c7* (car dp))
X (setq dp (cdr dp))
X (setq *c8* (car dp))
X (setq dp (cdr dp))
X (setq *c9* (car dp))
X (setq dp (cdr dp))
X (setq *c10* (car dp))
X (setq dp (cdr dp))
X (setq *c11* (car dp))
X (setq dp (cdr dp))
X (setq *c12* (car dp))
X (setq dp (cdr dp))
X (setq *c13* (car dp))
X (setq dp (cdr dp))
X (setq *c14* (car dp))
X (setq dp (cdr dp))
X (setq *c15* (car dp))
X (setq dp (cdr dp))
X (setq *c16* (car dp))
X (setq dp (cdr dp))
X (setq *c17* (car dp))
X (setq dp (cdr dp))
X (setq *c18* (car dp))
X (setq dp (cdr dp))
X (setq *c19* (car dp))
X (setq dp (cdr dp))
X (setq *c20* (car dp))
X (setq dp (cdr dp))
X (setq *c21* (car dp))
X (setq dp (cdr dp))
X (setq *c22* (car dp))
X (setq dp (cdr dp))
X (setq *c23* (car dp))
X (setq dp (cdr dp))
X (setq *c24* (car dp))
X (setq dp (cdr dp))
X (setq *c25* (car dp))
X (setq dp (cdr dp))
X (setq *c26* (car dp))
X (setq dp (cdr dp))
X (setq *c27* (car dp))
X (setq dp (cdr dp))
X (setq *c28* (car dp))
X (setq dp (cdr dp))
X (setq *c29* (car dp))
X (setq dp (cdr dp))
X (setq *c30* (car dp))
X (setq dp (cdr dp))
X (setq *c31* (car dp))
X (setq dp (cdr dp))
X (setq *c32* (car dp))
X (setq dp (cdr dp))
X (setq *c33* (car dp))
X (setq dp (cdr dp))
X (setq *c34* (car dp))
X (setq dp (cdr dp))
X (setq *c35* (car dp))
X (setq dp (cdr dp))
X (setq *c36* (car dp))
X (setq dp (cdr dp))
X (setq *c37* (car dp))
X (setq dp (cdr dp))
X (setq *c38* (car dp))
X (setq dp (cdr dp))
X (setq *c39* (car dp))
X (setq dp (cdr dp))
X (setq *c40* (car dp))
X (setq dp (cdr dp))
X (setq *c41* (car dp))
X (setq dp (cdr dp))
X (setq *c42* (car dp))
X (setq dp (cdr dp))
X (setq *c43* (car dp))
X (setq dp (cdr dp))
X (setq *c44* (car dp))
X (setq dp (cdr dp))
X (setq *c45* (car dp))
X (setq dp (cdr dp))
X (setq *c46* (car dp))
X (setq dp (cdr dp))
X (setq *c47* (car dp))
X (setq dp (cdr dp))
X (setq *c48* (car dp))
X (setq dp (cdr dp))
X (setq *c49* (car dp))
X (setq dp (cdr dp))
X (setq *c50* (car dp))
X (setq dp (cdr dp))
X (setq *c51* (car dp))
X (setq dp (cdr dp))
X (setq *c52* (car dp))
X (setq dp (cdr dp))
X (setq *c53* (car dp))
X (setq dp (cdr dp))
X (setq *c54* (car dp))
X (setq dp (cdr dp))
X (setq *c55* (car dp))
X (setq dp (cdr dp))
X (setq *c56* (car dp))
X (setq dp (cdr dp))
X (setq *c57* (car dp))
X (setq dp (cdr dp))
X (setq *c58* (car dp))
X (setq dp (cdr dp))
X (setq *c59* (car dp))
X (setq dp (cdr dp))
X (setq *c60* (car dp))
X (setq dp (cdr dp))
X (setq *c61* (car dp))
X (setq dp (cdr dp))
X (setq *c62* (car dp))
X (setq dp (cdr dp))
X (setq *c63* (car dp))
X (setq dp (cdr dp))
X (setq *c64* (car dp))
X (eval-nodelist outs)))
X
X(defun &any (outs register const-list)
X (prog (z c)
X (setq z (fast-symeval register))
X (cond ((numberp z) (go number)))
X symbol (cond ((null const-list) (return nil))
X ((eq (car const-list) z) (go ok))
X (t (setq const-list (cdr const-list)) (go symbol)))
X number (cond ((null const-list) (return nil))
X ((and (numberp (setq c (car const-list)))
X (=alg c z))
X (go ok))
X (t (setq const-list (cdr const-list)) (go number)))
X ok (eval-nodelist outs)))
X
X(defun teqa (outs register constant)
X (and (eq (fast-symeval register) constant) (eval-nodelist outs)))
X
X(defun tnea (outs register constant)
X (and (not (eq (fast-symeval register) constant)) (eval-nodelist outs)))
X
X(defun txxa (outs register constant)
X (and (symbolp (fast-symeval register)) (eval-nodelist outs)))
X
X(defun teqn (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (=alg z constant)
X (eval-nodelist outs))))
X
X(defun tnen (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (or (not (numberp z))
X (not (=alg z constant)))
X (eval-nodelist outs))))
X
X(defun txxn (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z) (eval-nodelist outs))))
X
X(defun tltn (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (greaterp constant z)
X (eval-nodelist outs))))
X
X(defun tgtn (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (greaterp z constant)
X (eval-nodelist outs))))
X
X(defun tgen (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (not (greaterp constant z))
X (eval-nodelist outs))))
X
X(defun tlen (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (not (greaterp z constant))
X (eval-nodelist outs))))
X
X(defun teqs (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (cond ((eq a b) (eval-nodelist outs))
X ((and (numberp a)
X (numberp b)
X (=alg a b))
X (eval-nodelist outs)))))
X
X(defun tnes (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (cond ((eq a b) (return nil))
X ((and (numberp a)
X (numberp b)
X (=alg a b))
X (return nil))
X (t (eval-nodelist outs)))))
X
X(defun txxs (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (cond ((and (numberp a) (numberp b)) (eval-nodelist outs))
X ((and (not (numberp a)) (not (numberp b)))
X (eval-nodelist outs)))))
X
X(defun tlts (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (and (numberp a)
X (numberp b)
X (greaterp b a)
X (eval-nodelist outs))))
X
X(defun tgts (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (and (numberp a)
X (numberp b)
X (greaterp a b)
X (eval-nodelist outs))))
X
X(defun tges (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (and (numberp a)
X (numberp b)
X (not (greaterp b a))
X (eval-nodelist outs))))
X
X(defun tles (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (and (numberp a)
X (numberp b)
X (not (greaterp a b))
X (eval-nodelist outs))))
X
X(defun &two (left-outs right-outs)
X (prog (fp dp)
X (cond (*sendtocall*
X (setq fp *flag-part*)
X (setq dp *data-part*))
X (t
X (setq fp *alpha-flag-part*)
X (setq dp *alpha-data-part*)))
X (sendto fp dp 'left left-outs)
X (sendto fp dp 'right right-outs)))
X
X(defun &mem (left-outs right-outs memory-list)
X (prog (fp dp)
X (cond (*sendtocall*
X (setq fp *flag-part*)
X (setq dp *data-part*))
X (t
X (setq fp *alpha-flag-part*)
X (setq dp *alpha-data-part*)))
X (sendto fp dp 'left left-outs)
X (add-token memory-list fp dp nil)
X (sendto fp dp 'right right-outs)))
X
X(defun &and (outs lpred rpred tests)
X (prog (mem)
X (cond ((eq *side* 'right) (setq mem (memory-part lpred)))
X (t (setq mem (memory-part rpred))))
X (cond ((not mem) (return nil))
X ((eq *side* 'right) (and-right outs mem tests))
X (t (and-left outs mem tests)))))
X
X(defun and-left (outs mem tests)
X (prog (fp dp memdp tlist tst lind rind res)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X fail (and (null mem) (return nil))
X (setq memdp (car mem))
X (setq mem (cdr mem))
X (setq tlist tests)
X tloop (and (null tlist) (go succ))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X (comment the next line differs in and-left & -right)
X (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
X (cond (res (go tloop))
X (t (go fail)))
X succ (comment the next line differs in and-left & -right)
X (sendto fp (cons (car memdp) dp) 'left outs)
X (go fail)))
X
X(defun and-right (outs mem tests)
X (prog (fp dp memdp tlist tst lind rind res)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X fail (and (null mem) (return nil))
X (setq memdp (car mem))
X (setq mem (cdr mem))
X (setq tlist tests)
X tloop (and (null tlist) (go succ))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X (comment the next line differs in and-left & -right)
X (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
X (cond (res (go tloop))
X (t (go fail)))
X succ (comment the next line differs in and-left & -right)
X (sendto fp (cons (car dp) memdp) 'right outs)
X (go fail)))
X
X
X(defun teqb (new eqvar)
X (cond ((eq new eqvar) t)
X ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((=alg new eqvar) t)
X (t nil)))
X
X(defun tneb (new eqvar)
X (cond ((eq new eqvar) nil)
X ((not (numberp new)) t)
X ((not (numberp eqvar)) t)
X ((=alg new eqvar) nil)
X (t t)))
X
X(defun tltb (new eqvar)
X (cond ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((greaterp eqvar new) t)
X (t nil)))
X
X(defun tgtb (new eqvar)
X (cond ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((greaterp new eqvar) t)
X (t nil)))
X
X(defun tgeb (new eqvar)
X (cond ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((not (greaterp eqvar new)) t)
X (t nil)))
X
X(defun tleb (new eqvar)
X (cond ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((not (greaterp new eqvar)) t)
X (t nil)))
X
X(defun txxb (new eqvar)
X (cond ((numberp new)
X (cond ((numberp eqvar) t)
X (t nil)))
X (t
X (cond ((numberp eqvar) nil)
X (t t)))))
X
X
X(defun &p (rating name var-dope ce-var-dope rhs)
X (prog (fp dp)
X (cond (*sendtocall*
X (setq fp *flag-part*)
X (setq dp *data-part*))
X (t
X (setq fp *alpha-flag-part*)
X (setq dp *alpha-data-part*)))
X (and (memq fp '(nil old)) (removecs name dp))
X (and fp (insertcs name dp rating))))
X
X(defun &old (a b c d e) nil)
X
X(defun ¬ (outs lmem rpred tests)
X (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil)
X ((eq *side* 'right) (not-right outs (car lmem) tests))
X (t (not-left outs (memory-part rpred) tests lmem))))
X
X(defun not-left (outs mem tests own-mem)
X (prog (fp dp memdp tlist tst lind rind res c)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X (setq c 0.)
X fail (and (null mem) (go fin))
X (setq memdp (car mem))
X (setq mem (cdr mem))
X (setq tlist tests)
X tloop (and (null tlist) (setq c (1+ c)) (go fail))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X (comment the next line differs in not-left & -right)
X (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
X (cond (res (go tloop))
X (t (go fail)))
X fin (add-token own-mem fp dp c)
X (and (== c 0.) (sendto fp dp 'left outs))))
X
X(defun not-right (outs mem tests)
X (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X (cond ((not fp) (setq inc -1.) (setq newfp 'new))
X ((eq fp 'new) (setq inc 1.) (setq newfp nil))
X (t (return nil)))
X fail (and (null mem) (return nil))
X (setq memdp (car mem))
X (setq newc (cadr mem))
X (setq tlist tests)
X tloop (and (null tlist) (go succ))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X (comment the next line differs in not-left & -right)
X (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
X (cond (res (go tloop))
X (t (setq mem (cddr mem)) (go fail)))
X succ (setq newc (+ inc newc))
X (rplaca (cdr mem) newc)
X (cond ((or (and (== inc -1.) (== newc 0.))
X (and (== inc 1.) (== newc 1.)))
X (sendto newfp memdp 'right outs)))
X (setq mem (cddr mem))
X (go fail)))
X
X
X
X;;; Node memories
X
X
X(defun add-token (memlis flag data-part num)
X (prog (was-present)
X (cond ((eq flag 'new)
X (setq was-present nil)
X (real-add-token memlis data-part num))
X ((not flag)
X (setq was-present (remove-old memlis data-part num)))
X ((eq flag 'old) (setq was-present t)))
X (return was-present)))
X
X(defun real-add-token (lis data-part num)
X (setq *current-token* (1+ *current-token*))
X (cond (num (rplaca lis (cons num (car lis)))))
X (rplaca lis (cons data-part (car lis))))
X
X(defun remove-old (lis data num)
X (cond (num (remove-old-num lis data))
X (t (remove-old-no-num lis data))))
X
X(defun remove-old-num (lis data)
X (prog (m next last)
X (setq m (car lis))
X (cond ((atom m) (return nil))
X ((top-levels-eq data (car m))
X (setq *current-token* (1- *current-token*))
X (rplaca lis (cddr m))
X (return (car m))))
X (setq next m)
X loop (setq last next)
X (setq next (cddr next))
X (cond ((atom next) (return nil))
X ((top-levels-eq data (car next))
X (rplacd (cdr last) (cddr next))
X (setq *current-token* (1- *current-token*))
X (return (car next)))
X (t (go loop)))))
X
X(defun remove-old-no-num (lis data)
X (prog (m next last)
X (setq m (car lis))
X (cond ((atom m) (return nil))
X ((top-levels-eq data (car m))
X (setq *current-token* (1- *current-token*))
X (rplaca lis (cdr m))
X (return (car m))))
X (setq next m)
X loop (setq last next)
X (setq next (cdr next))
X (cond ((atom next) (return nil))
X ((top-levels-eq data (car next))
X (rplacd last (cdr next))
X (setq *current-token* (1- *current-token*))
X (return (car next)))
X (t (go loop)))))
X
X
X
X;;; Conflict Resolution
X;
X;
X; each conflict set element is a list of the following form:
X; ((p-name . data-part) (sorted wm-recency) special-case-number)
X
X(defun removecs (name data)
X (prog (cr-data inst cs)
X (setq cr-data (cons name data))
X (setq cs *conflict-set*)
X l: (cond ((null cs)
X (record-refract name data)
X (return nil)))
X (setq inst (car cs))
X (setq cs (cdr cs))
X (and (not (top-levels-eq (car inst) cr-data)) (go l:))
X (setq *conflict-set* (delq inst *conflict-set*))))
X
X(defun insertcs (name data rating)
X (prog (instan)
X (and (refracted name data) (return nil))
X (setq instan (list (cons name data) (order-tags data) rating))
X (and (atom *conflict-set*) (setq *conflict-set* nil))
X (return (setq *conflict-set* (cons instan *conflict-set*)))))
X
X(defun order-tags (dat)
X (prog (tags)
X (setq tags nil)
X l1: (and (atom dat) (go l2:))
X (setq tags (cons (creation-time (car dat)) tags))
X (setq dat (cdr dat))
X (go l1:)
X l2: (cond ((eq *strategy* 'mea)
X (return (cons (car tags) (dsort (cdr tags)))))
X (t (return (dsort tags))))))
X
X; destructively sort x into descending order
X
X(defun dsort (x)
X (prog (sorted cur next cval nval)
X (and (atom (cdr x)) (return x))
X loop (setq sorted t)
X (setq cur x)
X (setq next (cdr x))
X chek (setq cval (car cur))
X (setq nval (car next))
X (cond ((> nval cval)
X (setq sorted nil)
X (rplaca cur nval)
X (rplaca next cval)))
X (setq cur next)
X (setq next (cdr cur))
X (cond ((not (null next)) (go chek))
X (sorted (return x))
X (t (go loop)))))
X
X(defun conflict-resolution nil
X (prog (best len)
X (setq len (length *conflict-set*))
X (cond ((> len *max-cs*) (setq *max-cs* len)))
X (setq *total-cs* (+ *total-cs* len))
X (cond (*conflict-set*
X (setq best (best-of *conflict-set*))
X (setq *conflict-set* (delq best *conflict-set*))
X (return (pname-instantiation best)))
X (t (return nil)))))
X
X(defun best-of (set) (best-of* (car set) (cdr set)))
X
X(defun best-of* (best rem)
X (cond ((not rem) best)
X ((conflict-set-compare best (car rem))
X (best-of* best (cdr rem)))
X (t (best-of* (car rem) (cdr rem)))))
X
X(defun remove-from-conflict-set (name)
X (prog (cs entry)
X l1 (setq cs *conflict-set*)
X l2 (cond ((atom cs) (return nil)))
X (setq entry (car cs))
X (setq cs (cdr cs))
X (cond ((eq name (caar entry))
X (setq *conflict-set* (delq entry *conflict-set*))
X (go l1))
X (t (go l2)))))
X
X(defun pname-instantiation (conflict-elem) (car conflict-elem))
X
X(defun order-part (conflict-elem) (cdr conflict-elem))
X
X(defun instantiation (conflict-elem)
X (cdr (pname-instantiation conflict-elem)))
X
X
X(defun conflict-set-compare (x y)
X (prog (x-order y-order xl yl xv yv)
X (setq x-order (order-part x))
X (setq y-order (order-part y))
X (setq xl (car x-order))
X (setq yl (car y-order))
X data (cond ((and (null xl) (null yl)) (go ps))
X ((null yl) (return t))
X ((null xl) (return nil)))
X (setq xv (car xl))
X (setq yv (car yl))
X (cond ((> xv yv) (return t))
X ((> yv xv) (return nil)))
X (setq xl (cdr xl))
X (setq yl (cdr yl))
X (go data)
X ps (setq xl (cdr x-order))
X (setq yl (cdr y-order))
X psl (cond ((null xl) (return t)))
X (setq xv (car xl))
X (setq yv (car yl))
X (cond ((> xv yv) (return t))
X ((> yv xv) (return nil)))
X (setq xl (cdr xl))
X (setq yl (cdr yl))
X (go psl)))
X
X
X(defun conflict-set nil
X (prog (cnts cs p z best)
X (setq cnts nil)
X (setq cs *conflict-set*)
X l1: (and (atom cs) (go l2:))
X (setq p (caaar cs))
X (setq cs (cdr cs))
X (setq z (assq p cnts))
X (cond ((null z) (setq cnts (cons (cons p 1.) cnts)))
X (t (rplacd z (1+ (cdr z)))))
X (go l1:)
X l2: (cond ((atom cnts)
X (setq best (best-of *conflict-set*))
X (terpri)
X (return (list (caar best) 'dominates))))
X (terpri)
X (princ (caar cnts))
X (cond ((> (cdar cnts) 1.)
X (princ '| (|)
X (princ (cdar cnts))
X (princ '| occurrences)|)))
X (setq cnts (cdr cnts))
X (go l2:)))
X
X
X
X;;; WM maintaining functions
X;
X; The order of operations in the following two functions is critical.
X; add-to-wm order: (1) change wm (2) record change (3) match
X; remove-from-wm order: (1) record change (2) match (3) change wm
X; (back will not restore state properly unless wm changes are recorded
X; before the cs changes that they cause) (match will give errors if
X; the thing matched is not in wm at the time)
X
X
X(defun add-to-wm (wme override)
X (prog (fa z part timetag port)
X (setq *critical* t)
X (setq *current-wm* (1+ *current-wm*))
X (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
X (setq *action-count* (1+ *action-count*))
X (setq fa (wm-hash wme))
X (or (memq fa *wmpart-list*)
X (setq *wmpart-list* (cons fa *wmpart-list*)))
X (setq part (get fa 'wmpart*))
X (cond (override (setq timetag override))
X (t (setq timetag *action-count*)))
X (setq z (cons wme timetag))
X (putprop fa (cons z part) 'wmpart*)
X (record-change '=>wm *action-count* wme)
X (match 'new wme)
X (setq *critical* nil)
X (cond ((and *in-rhs* *wtrace*)
X (setq port (trace-file))
X (terpri port)
X (princ '|=>wm: | port)
X (ppelm wme port)))
X (and *in-rhs* *mtrace* (setq *madeby*
X (cons (cons wme *p-name*) *madeby*)))))
X
X; remove-from-wm uses eq, not equal to determine if wme is present
X
X(defun remove-from-wm (wme)
X (prog (fa z part timetag port)
X (setq fa (wm-hash wme))
X (setq part (get fa 'wmpart*))
X (setq z (assq wme part))
X (or z (return nil))
X (setq timetag (cdr z))
X (cond ((and *wtrace* *in-rhs*)
X (setq port (trace-file))
X (terpri port)
X (princ '|<=wm: | port)
X (ppelm wme port)))
X (setq *action-count* (1+ *action-count*))
X (setq *critical* t)
X (setq *current-wm* (1- *current-wm*))
X (record-change '<=wm timetag wme)
X (match nil wme)
X (putprop fa (delq z part) 'wmpart*)
X (setq *critical* nil)))
X
X; mapwm maps down the elements of wm, applying fn to each element
X; each element is of form (datum . creation-time)
X
X(defun mapwm (fn)
X (prog (wmpl part)
X (setq wmpl *wmpart-list*)
X lab1 (cond ((atom wmpl) (return nil)))
X (setq part (get (car wmpl) 'wmpart*))
X (setq wmpl (cdr wmpl))
X (mapc fn part)
X (go lab1)))
X
X(defun wm fexpr (a)
X (mapc (function (lambda (z) (terpri) (ppelm z t)))
X (get-wm a))
X nil)
X
X(defun get-wm (z)
X (setq *wm-filter* z)
X (setq *wm* nil)
X (mapwm (function get-wm2))
X (prog2 nil *wm* (setq *wm* nil)))
X
X(defun get-wm2 (elem)
X (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*))
X (setq *wm* (cons (car elem) *wm*)]
X
X(defun wm-hash (x)
X (cond ((not x) '<default>)
X ((not (car x)) (wm-hash (cdr x)))
X ((symbolp (car x)) (car x))
X (t (wm-hash (cdr x)))))
X
X(defun creation-time (wme)
X (cdr (assq wme (get (wm-hash wme) 'wmpart*))))
X
X(defun rehearse nil
X (prog nil
X (setq *old-wm* nil)
X (mapwm (function refresh-collect))
X (mapc (function refresh-del) *old-wm*)
X (mapc (function refresh-add) *old-wm*)
X (setq *old-wm* nil)))
X
X(defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*)))
X
X(defun refresh-del (x) (remove-from-wm (car x)))
X
X(defun refresh-add (x) (add-to-wm (car x) (cdr x)))
X
X(defun trace-file ()
X (prog (port)
X (setq port t)
X (cond (*trace-file*
X (setq port ($ofile *trace-file*))
X (cond ((null port)
X (%warn '|trace: file has been closed| *trace-file*)
X (setq port t)))))
X (return port)))
X
X
X;;; Basic functions for RHS evaluation
X
X(defun eval-rhs (pname data)
X (prog (node port)
X (cond (*ptrace*
X (setq port (trace-file))
X (terpri port)
X (princ *cycle-count* port)
X (princ '|. | port)
X (princ pname port)
X (time-tag-print data port)))
X (setq *data-matched* data)
X (setq *p-name* pname)
X (setq *last* nil)
X (setq node (get pname 'topnode))
X (init-var-mem (var-part node))
X (init-ce-var-mem (ce-var-part node))
X (begin-record pname data)
X (setq *in-rhs* t)
X (eval (rhs-part node))
X (setq *in-rhs* nil)
X (end-record)))
X
X(defun time-tag-print (data port)
X (cond ((not (null data))
X (time-tag-print (cdr data) port)
X (princ '| | port)
X (princ (creation-time (car data)) port))))
X
X(defun init-var-mem (vlist)
X (prog (v ind r)
X (setq *variable-memory* nil)
X top (and (atom vlist) (return nil))
X (setq v (car vlist))
X (setq ind (cadr vlist))
X (setq vlist (cddr vlist))
X (setq r (gelm *data-matched* ind))
X (setq *variable-memory* (cons (cons v r) *variable-memory*))
X (go top)))
X
X(defun init-ce-var-mem (vlist)
X (prog (v ind r)
X (setq *ce-variable-memory* nil)
X top (and (atom vlist) (return nil))
X (setq v (car vlist))
X (setq ind (cadr vlist))
X (setq vlist (cddr vlist))
X (setq r (ce-gelm *data-matched* ind))
X (setq *ce-variable-memory*
X (cons (cons v r) *ce-variable-memory*))
X (go top)))
X
X(defun make-ce-var-bind (var elem)
X (setq *ce-variable-memory*
X (cons (cons var elem) *ce-variable-memory*)))
X
X(defun make-var-bind (var elem)
X (setq *variable-memory* (cons (cons var elem) *variable-memory*)))
X
X(defun $varbind (x)
X (prog (r)
X (and (not *in-rhs*) (return x))
X (setq r (assq x *variable-memory*))
X (cond (r (return (cdr r)))
X (t (return x)))))
X
X(defun get-ce-var-bind (x)
X (prog (r)
X (cond ((numberp x) (return (get-num-ce x))))
X (setq r (assq x *ce-variable-memory*))
X (cond (r (return (cdr r)))
X (t (return nil)))))
X
X(defun get-num-ce (x)
X (prog (r l d)
X (setq r *data-matched*)
X (setq l (length r))
X (setq d (- l x))
X (and (> 0. d) (return nil))
X la (cond ((null r) (return nil))
X ((> 1. d) (return (car r))))
X (setq d (1- d))
X (setq r (cdr r))
X (go la)))
X
X
X(defun build-collect (z)
X (prog (r)
X la (and (atom z) (return nil))
X (setq r (car z))
X (setq z (cdr z))
X (cond ((dtpr r)
X ($value '\()
X (build-collect r)
X ($value '\)))
X ((eq r '\\) ($change (car z)) (setq z (cdr z)))
X (t ($value r)))
X (go la)))
X
X(defun unflat (x) (setq *rest* x) (unflat*))
X
X(defun unflat* nil
X (prog (c)
X (cond ((atom *rest*) (return nil)))
X (setq c (car *rest*))
X (setq *rest* (cdr *rest*))
X (cond ((eq c '\() (return (cons (unflat*) (unflat*))))
X ((eq c '\)) (return nil))
X (t (return (cons c (unflat*)))))))
X
X
X(defun $change (x)
X (prog nil
X (cond ((dtpr x) (eval-function x))
X (t ($value ($varbind x))))))
X
X(defun eval-args (z)
X (prog (r)
X (rhs-tab 1.)
X la (and (atom z) (return nil))
X (setq r (car z))
X (setq z (cdr z))
X (cond ((eq r '^)
X (rhs-tab (car z))
X (setq r (cadr z))
X (setq z (cddr z))))
X (cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
X (t ($change r)))
X (go la)))
X
X
X(defun eval-function (form)
X (cond ((not *in-rhs*)
X (%warn '|functions cannot be used at top level| (car form)))
X (t (eval form))))
X
X
X;;; Functions to manipulate the result array
X
X
X(defun $reset nil
X (setq *max-index* 0.)
X (setq *next-index* 1.))
X
X; rhs-tab implements the tab ('^') function in the rhs. it has
X; four responsibilities:
X; - to move the array pointers
X; - to watch for tabbing off the left end of the array
X; (ie, to watch for pointers less than 1)
X; - to watch for tabbing off the right end of the array
X; - to write nil in all the slots that are skipped
X; the last is necessary if the result array is not to be cleared
X; after each use; if rhs-tab did not do this, $reset
X; would be much slower.
X
X(defun rhs-tab (z) ($tab ($varbind z)))
X
X(defun $tab (z)
X (prog (edge next)
X (setq next ($litbind z))
X (and (floatp next) (setq next (fix next)))
X (cond ((or (not (numberp next))
X (> next *size-result-array*)
X (> 1. next))
X (%warn '|illegal index after ^| next)
X (return *next-index*)))
X (setq edge (- next 1.))
X (cond ((> *max-index* edge) (go ok)))
X clear (cond ((== *max-index* edge) (go ok)))
X (putvector *result-array* edge nil)
X (setq edge (1- edge))
X (go clear)
X ok (setq *next-index* next)
X (return next)))
X
X(defun $value (v)
X (cond ((> *next-index* *size-result-array*)
X (%warn '|index too large| *next-index*))
X (t
X (and (> *next-index* *max-index*)
X (setq *max-index* *next-index*))
X (putvector *result-array* *next-index* v)
X (setq *next-index* (1+ *next-index*)))))
X
X(defun use-result-array nil
X (prog (k r)
X (setq k *max-index*)
X (setq r nil)
X top (and (== k 0.) (return r))
X (setq r (cons (getvector *result-array* k) r))
X (setq k (1- k))
X (go top)))
X
X(defun $assert nil
X (setq *last* (use-result-array))
X (add-to-wm *last* nil))
X
X(defun $parametercount nil *max-index*)
X
X(defun $parameter (k)
X (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
X (%warn '|illegal parameter number | k)
X nil)
X ((> k *max-index*) nil)
X (t (getvector *result-array* k))))
X
X
X;;; RHS actions
X
X(defun make fexpr (z)
X (prog nil
X ($reset)
X (eval-args z)
X ($assert)))
X
X(defun modify fexpr (z)
X (prog (old)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'modify)
--
---------------
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-9400turner@imagen.UUCP (D'arc Angel) (01/19/87)
X(proclaim '(special *matrix* *feature-count* *pcount* *vars* *cur-vars*
X *curcond* *subnum* *last-node* *last-branch* *first-node*
X *sendtocall* *flag-part* *alpha-flag-part* *data-part*
X *alpha-data-part* *ce-vars* *virtual-cnt* *real-cnt*
X *current-token* *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
X *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
X *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
X *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
X *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
X *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
X *c60* *c61* *c62* *c63* *c64* *record-array* *result-array*
X *max-cs* *total-cs* *limit-cs* *cr-temp* *side*
X *conflict-set* *halt-flag* *phase* *critical*
X *cycle-count* *total-token* *max-token* *refracts*
X *limit-token* *total-wm* *current-wm* *max-wm*
X *action-count* *wmpart-list* *wm* *data-matched* *p-name*
X *variable-memory* *ce-variable-memory*
X *max-index* ; number of right-most field in wm element
X *next-index* *size-result-array* *rest* *build-trace* *last*
X *ptrace* *wtrace* *in-rhs* *recording* *accept-file* *trace-file*
X *mtrace* *madeby* ; used to trace and record makers of elements
X *write-file* *record-index* *max-record-index* *old-wm*
X *record* *filters* *break-flag* *strategy* *remaining-cycles*
X *wm-filter* *rhs-bound-vars* *rhs-bound-ce-vars* *ppline*
X *ce-count* *brkpts* *class-list* *buckets* *action-type*
X *literals* ;stores literal definitions
X *pnames* ;stores production names
X *externals* ;tracks external declarations
X *vector-attributes* ;list of vector-attributes
X ))
X
X;(declare (localf ce-gelm gelm peek-sublex sublex
X; eval-nodelist sendto and-left and-right not-left not-right
X; top-levels-eq add-token real-add-token remove-old
X; remove-old-num remove-old-no-num removecs insertcs dsort
X; best-of best-of* conflict-set-compare =alg ))
X
X
X;;; Functions that were revised so that they would compile efficiently
X
X
X;* The function == is machine dependent\!
X;* This function compares small integers for equality. It uses EQ
X;* so that it will be fast, and it will consequently not work on all
X;* Lisps. It works in Franz Lisp for integers in [-128, 127]
X
X
X;(defun == (&rest z) (= (cadr z) (caddr z)))
X(defun == (x y) (= x y))
X
X; =ALG returns T if A and B are algebraicly equal.
X
X(defun =alg (a b) (= a b))
X
X(defmacro fast-symeval (&rest z)
X `(cond ((eq ,(car z) '*c1*) *c1*)
X ((eq ,(car z) '*c2*) *c2*)
X ((eq ,(car z) '*c3*) *c3*)
X ((eq ,(car z) '*c4*) *c4*)
X ((eq ,(car z) '*c5*) *c5*)
X ((eq ,(car z) '*c6*) *c6*)
X ((eq ,(car z) '*c7*) *c7*)
X (t (eval ,(car z))) ))
X
X; getvector and putvector are fast routines for using one-dimensional
X; arrays. these routines do no checking; they assume
X; 1. the array is a vector with 0 being the index of the first
X; element
X; 2. the vector holds arbitrary list values
X;defun versions are useful for tracing
X
X; Example call: (putvector array index value)
X
X(defmacro putvector (array_ref ind var)
X `(setf (aref ,array_ref ,ind) ,var))
X
X;(defun putvector (array_ref ind var)
X; (setf (aref array_ref ind) var))
X
X; Example call: (getvector name index)
X
X;(defmacro getvector(&rest z)
X; (list 'cxr (caddr z) (cadr z)))
X
X(defmacro getvector(array_ref ind)
X `(aref ,array_ref ,ind))
X
X;(defun getvector (array_ref ind)
X ; (aref array_ref ind))
X
X(defun ce-gelm (x k)
X (prog nil
X loop (and (== k 1.) (return (car x)))
X (setq k (1- k))
X (setq x (cdr x))
X (go loop)))
X
X; The loops in gelm were unwound so that fewer calls on DIFFERENCE
X; would be needed
X
X(defun gelm (x k)
X (prog (ce sub)
X (setq ce (floor (/ k 10000)))
X (setq sub (- k (* ce 10000)))
X celoop (and (== ce 0) (go ph2))
X (setq x (cdr x))
X (and (== ce 1) (go ph2))
X (setq x (cdr x))
X (and (== ce 2) (go ph2))
X (setq x (cdr x))
X (and (== ce 3) (go ph2))
X (setq x (cdr x))
X (and (== ce 4) (go ph2))
X (setq ce (- ce 4))
X (go celoop)
X ph2 (setq x (car x))
X subloop (and (== sub 0) (go finis))
X (setq x (cdr x))
X (and (== sub 1) (go finis))
X (setq x (cdr x))
X (and (== sub 2) (go finis))
X (setq x (cdr x))
X (and (== sub 3) (go finis))
X (setq x (cdr x))
X (and (== sub 4) (go finis))
X (setq x (cdr x))
X (and (== sub 5) (go finis))
X (setq x (cdr x))
X (and (== sub 6) (go finis))
X (setq x (cdr x))
X (and (== sub 7) (go finis))
X (setq x (cdr x))
X (and (== sub 8) (go finis))
X (setq sub (- sub 8))
X (go subloop)
X finis (return (car x))))
X
X
X;;; Utility functions
X
X
X
X(defun printline (x) (mapc (function printline*) x))
X
X(defun printline* (y) (princ '| |) (print y))
X
X(defun printlinec (x) (mapc (function printlinec*) x))
X
X(defun printlinec* (y) (princ '| |) (princ y))
X
X; intersect two lists using eq for the equality test
X
X(defun interq (x y)
X (intersection x y :test #'eq))
X
X(defun enter (x ll)
X (and (not (member x ll :test #'equal))
X (push x ll)))
X
X; later versions of Franz have this standard
X;(defun neq (x y)
X; (not (eq x y)))
X
X;Hack read-macro tables to accept single characters -- right out of CL book.
X(defun single-macro-character (stream char)
X (declare (ignore stream))
X (character char))
X
X(defun i-g-v nil
X (prog (x)
X (set-macro-character #\{ #'single-macro-character )
X (set-macro-character #\} #'single-macro-character )
X (set-macro-character #\^ #'single-macro-character )
X; (setsyntax '\{ 66.) ;These are already normal characters in CL
X; (setsyntax '\} 66.)
X; (setsyntax '^ 66.)
X (setq *buckets* 64.) ; OPS5 allows 64 named slots
X (setq *accept-file* nil)
X (setq *write-file* nil)
X (setq *trace-file* nil)
X (and (boundp '*class-list*)
X (mapc #'(lambda(class) (putprop class nil 'att-list)) *class-list*))
X (setq *class-list* nil)
X (setq *brkpts* nil)
X (setq *strategy* 'lex)
X (setq *in-rhs* nil)
X (setq *ptrace* t)
X (setq *wtrace* nil)
X (setq *mtrace* t) ; turn on made-by tracing
X (setq *madeby* nil) ; record makers of wm elements
X (setq *recording* nil)
X (setq *refracts* nil)
X (setq *real-cnt* (setq *virtual-cnt* 0.))
X (setq *max-cs* (setq *total-cs* 0.))
X (setq *limit-token* 1000000.)
X (setq *limit-cs* 1000000.)
X (setq *critical* nil)
X (setq *build-trace* nil)
X (setq *wmpart-list* nil)
X (setq *pnames* nil)
X (setq *literals* nil) ; records literal definitions
X (setq *externals* nil) ; records external definitions
X (setq *vector-attributes* nil) ;records vector attributes
X (setq *size-result-array* 127.)
X (setq *result-array* (make-array 128))
X (setq *record-array* (make-array 128))
X (setq x 0)
X (setq *pnames* nil) ; list of production names
X loop (putvector *result-array* x nil)
X (setq x (1+ x))
X (and (not (> x *size-result-array*)) (go loop))
X (make-bottom-node)
X (setq *pcount* 0.)
X (initialize-record)
X (setq *cycle-count* (setq *action-count* 0.))
X (setq *total-token*
X (setq *max-token* (setq *current-token* 0.)))
X (setq *total-cs* (setq *max-cs* 0.))
X (setq *total-wm* (setq *max-wm* (setq *current-wm* 0.)))
X (setq *conflict-set* nil)
X (setq *wmpart-list* nil)
X (setq *p-name* nil)
X (setq *remaining-cycles* 1000000)
X))
X
X; if the size of result-array changes, change the line in i-g-v which
X; sets the value of *size-result-array*
X
X(defun %warn (what where)
X (prog nil
X (terpri)
X (princ '?)
X (and *p-name* (princ *p-name*))
X (princ '|..|)
X (princ where)
X (princ '|..|)
X (princ what)
X (return where)))
X
X(defun %error (what where)
X (%warn what where)
X (throw '!error! nil))
X
X;(defun round (x) (fix (plus 0.5 x)))
X
X(defun top-levels-eq (la lb)
X (prog nil
X lx (cond ((eq la lb) (return t))
X ((null la) (return nil))
X ((null lb) (return nil))
X ((not (eq (car la) (car lb))) (return nil)))
X (setq la (cdr la))
X (setq lb (cdr lb))
X (go lx)))
X
X
X;;; LITERAL and LITERALIZE
X
X(defmacro literal (&rest z)
X `(prog (atm val old args)
X (setq args ',z)
X top (and (atom args) (return 'bound))
X (or (eq (cadr args) '=) (return (%warn '|wrong format| args)))
X (setq atm (car args))
X (setq val (caddr args))
X (setq args (cdddr args))
X (cond ((not (numberp val))
X (%warn '|can bind only to numbers| val))
X ((or (not (symbolp atm)) (variablep atm))
X (%warn '|can bind only constant atoms| atm))
X ((and (setq old (literal-binding-of atm)) (not (equal old val)))
X (%warn '|attempt to rebind attribute| atm))
X (t (putprop atm val 'ops-bind )))
X (go top)))
X
X(defmacro literalize (&rest l)
X `(prog (class-name atts)
X (setq class-name (car ',l))
X (cond ((have-compiled-production)
X (%warn '|literalize called after p| class-name)
X (return nil))
X ((get class-name 'att-list)
X (%warn '|attempt to redefine class| class-name)
X (return nil)))
X (setq *class-list* (cons class-name *class-list*))
X (setq atts (remove-duplicates (cdr ',l)))
X (test-attribute-names atts)
X (mark-conflicts atts atts)
X (putprop class-name atts 'att-list)))
X
X(defun vector-attribute ("e &rest l)
X (cond ((have-compiled-production)
X (%warn '|vector-attribute called after p| l))
X (t
X (test-attribute-names l)
X (mapc (function vector-attribute2) l))))
X
X(defun vector-attribute2 (att) (putprop att t 'vector-attribute)
X (setq *vector-attributes*
X (enter att *vector-attributes*)))
X
X(defun is-vector-attribute (att) (get att 'vector-attribute))
X
X(defun test-attribute-names (l)
X (mapc (function test-attribute-names2) l))
X
X(defun test-attribute-names2 (atm)
X (cond ((or (not (symbolp atm)) (variablep atm))
X (%warn '|can bind only constant atoms| atm))))
X
X(defun finish-literalize nil
X (cond ((not (null *class-list*))
X (mapc (function note-user-assigns) *class-list*)
X (mapc (function assign-scalars) *class-list*)
X (mapc (function assign-vectors) *class-list*)
X (mapc (function put-ppdat) *class-list*)
X (mapc (function erase-literal-info) *class-list*)
X (setq *class-list* nil)
X (setq *buckets* nil))))
X
X(defun have-compiled-production nil (not (zerop *pcount*)))
X
X(defun put-ppdat (class)
X (prog (al att ppdat)
X (setq ppdat nil)
X (setq al (get class 'att-list))
X top (cond ((not (atom al))
X (setq att (car al))
X (setq al (cdr al))
X (setq ppdat
X (cons (cons (literal-binding-of att) att)
X ppdat))
X (go top)))
X (putprop class ppdat 'ppdat)))
X
X; note-user-assigns and note-user-vector-assigns are needed only when
X; literal and literalize are both used in a program. They make sure that
X; the assignments that are made explicitly with literal do not cause problems
X; for the literalized classes.
X
X(defun note-user-assigns (class)
X (mapc (function note-user-assigns2) (get class 'att-list)))
X
X(defun note-user-assigns2 (att)
X (prog (num conf buck clash)
X (setq num (literal-binding-of att))
X (and (null num) (return nil))
X (setq conf (get att 'conflicts))
X (setq buck (store-binding att num))
X (setq clash (find-common-atom buck conf))
X (and clash
X (%warn '|attributes in a class assigned the same number|
X (cons att clash)))
X (return nil)))
X
X(defun note-user-vector-assigns (att given needed)
X (and (> needed given)
X (%warn '|vector attribute assigned too small a value in literal| att)))
X
X(defun assign-scalars (class)
X (mapc (function assign-scalars2) (get class 'att-list)))
X
X(defun assign-scalars2 (att)
X (prog (tlist num bucket conf)
X (and (literal-binding-of att) (return nil))
X (and (is-vector-attribute att) (return nil))
X (setq tlist (buckets))
X (setq conf (get att 'conflicts))
X top (cond ((atom tlist)
X (%warn '|could not generate a binding| att)
X (store-binding att -1.)
X (return nil)))
X (setq num (caar tlist))
X (setq bucket (cdar tlist))
X (setq tlist (cdr tlist))
X (cond ((disjoint bucket conf) (store-binding att num))
X (t (go top)))))
X
X(defun assign-vectors (class)
X (mapc (function assign-vectors2) (get class 'att-list)))
X
X(defun assign-vectors2 (att)
X (prog (big conf new old need)
X (and (not (is-vector-attribute att)) (return nil))
X (setq big 1.)
X (setq conf (get att 'conflicts))
X top (cond ((not (atom conf))
X (setq new (car conf))
X (setq conf (cdr conf))
X (cond ((is-vector-attribute new)
X (%warn '|class has two vector attributes|
X (list att new)))
X (t (setq big (max (literal-binding-of new) big))))
X (go top)))
X (setq need (1+ big))
X (setq old (literal-binding-of att))
X (cond (old (note-user-vector-assigns att old need))
X (t (store-binding att need)))
X (return nil)))
X
X(defun disjoint (la lb) (not (find-common-atom la lb)))
X
X(defun find-common-atom (la lb)
X (prog nil
X top (cond ((null la) (return nil))
X ((memq (car la) lb) (return (car la)))
X (t (setq la (cdr la)) (go top)))))
X
X(defun mark-conflicts (rem all)
X (cond ((not (null rem))
X (mark-conflicts2 (car rem) all)
X (mark-conflicts (cdr rem) all))))
X
X(defun mark-conflicts2 (atm lst)
X (prog (l)
X (setq l lst)
X top (and (atom l) (return nil))
X (conflict atm (car l))
X (setq l (cdr l))
X (go top)))
X
X(defun conflict (a b)
X (prog (old)
X (setq old (get a 'conflicts))
X (and (not (eq a b))
X (not (memq b old))
X (putprop a (cons b old) 'conflicts ))))
X
X;(defun remove-duplicates (lst)
X; (cond ((atom lst) nil)
X; ((memq (car lst) (cdr lst)) (remove-duplicates (cdr lst)))
X; (t (cons (car lst) (remove-duplicates (cdr lst))))))
X
X(defun literal-binding-of (name) (get name 'ops-bind))
X
X(defun store-binding (name lit)
X (putprop name lit 'ops-bind)
X (add-bucket name lit))
X
X(defun add-bucket (name num)
X (prog (buc)
X (setq buc (assoc num (buckets)))
X (and (not (memq name buc))
X (rplacd buc (cons name (cdr buc))))
X (return buc)))
X
X(defun buckets nil
X (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
X *buckets*)
X
X(defun make-nums (k)
X (prog (nums)
X (setq nums nil)
X l (and (< k 2.) (return nums))
X (setq nums (cons (ncons k) nums))
X (setq k (1- k))
X (go l)))
X
X;(defun erase-literal-info (class)
X; (mapc (function erase-literal-info2) (get class 'att-list))
X; (remprop class 'att-list))
X
X; modified to record literal info in the variable *literals*
X(defun erase-literal-info (class)
X (setq *literals*
X (cons (cons class (get class 'att-list)) *literals*))
X (mapc (function erase-literal-info2) (get class 'att-list))
X (remprop class 'att-list))
X
X
X(defun erase-literal-info2 (att) (remprop att 'conflicts))
X
X
X;;; LHS Compiler
X
X(defun p ("e &rest z)
X (finish-literalize)
X (princ '*)
X ;(drain);drain probably drains a line feed
X (compile-production (car z) (cdr z)))
X
X(defun compile-production (name matrix)
X (prog (erm)
X (setq *p-name* name)
X (setq erm (catch '!error! (cmp-p name matrix) ))
X ; following line is modified to save production name on *pnames*
X (and (null erm) (setq *pnames* (enter name *pnames*)))
X (setq *p-name* nil)
X (return erm)))
X
X(defun peek-lex nil (car *matrix*))
X
X(defun lex nil
X (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*))))
X
X(defun end-of-p nil (atom *matrix*))
X
X(defun rest-of-p nil *matrix*)
X
X(defun prepare-lex (prod) (setq *matrix* prod))
X
X
X(defun peek-sublex nil (car *curcond*))
X
X(defun sublex nil
X (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*))))
X
X(defun end-of-ce nil (atom *curcond*))
X
X(defun rest-of-ce nil *curcond*)
X
X(defun prepare-sublex (ce) (setq *curcond* ce))
X
X(defun make-bottom-node nil (setq *first-node* (list '&bus nil)))
X
X(defun cmp-p (name matrix)
X (prog (m bakptrs)
X (cond ((or (null name) (listp name))
X (%error '|illegal production name| name))
X ((equal (get name 'production) matrix)
X (return nil)))
X (prepare-lex matrix)
X (excise-p name)
X (setq bakptrs nil)
X (setq *pcount* (1+ *pcount*))
X (setq *feature-count* 0.)
X (setq *ce-count* 0)
X (setq *vars* nil)
X (setq *ce-vars* nil)
X (setq *rhs-bound-vars* nil)
X (setq *rhs-bound-ce-vars* nil)
X (setq *last-branch* nil)
X (setq m (rest-of-p))
X l1 (and (end-of-p) (%error '|no '-->' in production| m))
X (cmp-prin)
X (setq bakptrs (cons *last-branch* bakptrs))
X (or (eq '--> (peek-lex)) (go l1))
X (lex)
X (check-rhs (rest-of-p))
X (link-new-node (list '&p
X *feature-count*
X name
X (encode-dope)
X (encode-ce-dope)
X (cons 'progn (rest-of-p))))
X (putprop name (cdr (nreverse bakptrs)) 'backpointers )
X (putprop name matrix 'production)
X (putprop name *last-node* 'topnode)))
X
X(defun rating-part (pnode) (cadr pnode))
X
X(defun var-part (pnode) (car (cdddr pnode)))
X
X(defun ce-var-part (pnode) (cadr (cdddr pnode)))
X
X(defun rhs-part (pnode) (caddr (cdddr pnode)))
X
X(defun excise-p (name)
X (cond ((and (symbolp name) (get name 'topnode))
X (printline (list name 'is 'excised))
X (setq *pcount* (1- *pcount*))
X (remove-from-conflict-set name)
X (kill-node (get name 'topnode))
X (setq *pnames* (delq name *pnames*))
X (remprop name 'production)
X (remprop name 'backpointers)
X (remprop name 'topnode))))
X
X(defun kill-node (node)
X (prog nil
X top (and (atom node) (return nil))
X (rplaca node '&old)
X (setq node (cdr node))
X (go top)))
X
X(defun cmp-prin nil
X (prog nil
X (setq *last-node* *first-node*)
X (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
X ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
X (t (cmp-posce) (cmp-and)))))
X
X(defun cmp-negce nil (lex) (cmp-ce))
X
X(defun cmp-posce nil
X (setq *ce-count* (1+ *ce-count*))
X (cond ((eq (peek-lex) #\{) (cmp-ce+cevar))
X (t (cmp-ce))))
X
X(defun cmp-ce+cevar nil
X (prog (z)
X (lex)
X (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
X (t (cmp-ce) (cmp-cevar)))
X (setq z (lex))
X (or (eq z #\}) (%error '|missing '}'| z))))
X
X(defun new-subnum (k)
X (or (numberp k) (%error '|tab must be a number| k))
X (setq *subnum* (fix k)))
X
X(defun incr-subnum nil (setq *subnum* (1+ *subnum*)))
X
X(defun cmp-ce nil
X (prog (z)
X (new-subnum 0.)
X (setq *cur-vars* nil)
X (setq z (lex))
X (and (atom z)
X (%error '|atomic conditions are not allowed| z))
X (prepare-sublex z)
X la (and (end-of-ce) (return nil))
X (incr-subnum)
X (cmp-element)
X (go la)))
X
X(defun cmp-element nil
X (and (eq (peek-sublex) #\^) (cmp-tab))
X (cond ((eq (peek-sublex) '#\{) (cmp-product))
X (t (cmp-atomic-or-any))))
X
X(defun cmp-atomic-or-any nil
X (cond ((eq (peek-sublex) '<<) (cmp-any))
X (t (cmp-atomic))))
X
X(defun cmp-any nil
X (prog (a z)
X (sublex)
X (setq z nil)
X la (cond ((end-of-ce) (%error '|missing '>>'| a)))
X (setq a (sublex))
X (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
X (link-new-node (list '&any nil (current-field) z))))
X
X
X(defun cmp-tab nil
X (prog (r)
X (sublex)
X (setq r (sublex))
X (setq r ($litbind r))
X (new-subnum r)))
X
X(defun $litbind (x)
X (prog (r)
X (cond ((and (symbolp x) (setq r (literal-binding-of x)))
X (return r))
X (t (return x)))))
X
X(defun get-bind (x)
X (prog (r)
X (cond ((and (symbolp x) (setq r (literal-binding-of x)))
X (return r))
X (t (return nil)))))
X
X(defun cmp-atomic nil
X (prog (test x)
X (setq x (peek-sublex))
X (cond ((eq x '=) (setq test 'eq) (sublex))
X ((eq x '<>) (setq test 'ne) (sublex))
X ((eq x '<) (setq test 'lt) (sublex))
X ((eq x '<=) (setq test 'le) (sublex))
X ((eq x '>) (setq test 'gt) (sublex))
X ((eq x '>=) (setq test 'ge) (sublex))
X ((eq x '<=>) (setq test 'xx) (sublex))
X (t (setq test 'eq)))
X (cmp-symbol test)))
X
X(defun cmp-product nil
X (prog (save)
X (setq save (rest-of-ce))
X (sublex)
X la (cond ((end-of-ce)
X (cond ((member #\} save)
X (%error '|wrong contex for '}'| save))
X (t (%error '|missing '}'| save))))
X ((eq (peek-sublex) #\}) (sublex) (return nil)))
X (cmp-atomic-or-any)
X (go la)))
X
X(defun variablep (x) (and (symbolp x) (char-equal (char (symbol-name x) 0) #\<)))
X
X(defun cmp-symbol (test)
X (prog (flag)
X (setq flag t)
X (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
X (cond ((and flag (variablep (peek-sublex)))
X (cmp-var test))
X ((numberp (peek-sublex)) (cmp-number test))
X ((symbolp (peek-sublex)) (cmp-constant test))
X (t (%error '|unrecognized symbol| (sublex))))))
X
X(defun concat3(x y z)
X (intern (format nil "~s~s~s" x y z)))
X
X(defun cmp-constant (test)
X (or (memq test '(eq ne xx))
X (%error '|non-numeric constant after numeric predicate| (sublex)))
X (link-new-node (list (concat3 't test 'a)
X nil
X (current-field)
X (sublex))))
X
X
X(defun cmp-number (test)
X (link-new-node (list (concat3 't test 'n)
X nil
X (current-field)
X (sublex))))
X
X(defun current-field nil (field-name *subnum*))
X
X(defun field-name (num)
X (cond ((= num 1.) '*c1*)
X ((= num 2.) '*c2*)
X ((= num 3.) '*c3*)
X ((= num 4.) '*c4*)
X ((= num 5.) '*c5*)
X ((= num 6.) '*c6*)
X ((= num 7.) '*c7*)
X ((= num 8.) '*c8*)
X ((= num 9.) '*c9*)
X ((= num 10.) '*c10*)
X ((= num 11.) '*c11*)
X ((= num 12.) '*c12*)
X ((= num 13.) '*c13*)
X ((= num 14.) '*c14*)
X ((= num 15.) '*c15*)
X ((= num 16.) '*c16*)
X ((= num 17.) '*c17*)
X ((= num 18.) '*c18*)
X ((= num 19.) '*c19*)
X ((= num 20.) '*c20*)
X ((= num 21.) '*c21*)
X ((= num 22.) '*c22*)
X ((= num 23.) '*c23*)
X ((= num 24.) '*c24*)
X ((= num 25.) '*c25*)
X ((= num 26.) '*c26*)
X ((= num 27.) '*c27*)
X ((= num 28.) '*c28*)
X ((= num 29.) '*c29*)
X ((= num 30.) '*c30*)
X ((= num 31.) '*c31*)
X ((= num 32.) '*c32*)
X ((= num 33.) '*c33*)
X ((= num 34.) '*c34*)
X ((= num 35.) '*c35*)
X ((= num 36.) '*c36*)
X ((= num 37.) '*c37*)
X ((= num 38.) '*c38*)
X ((= num 39.) '*c39*)
X ((= num 40.) '*c40*)
X ((= num 41.) '*c41*)
X ((= num 42.) '*c42*)
X ((= num 43.) '*c43*)
X ((= num 44.) '*c44*)
X ((= num 45.) '*c45*)
X ((= num 46.) '*c46*)
X ((= num 47.) '*c47*)
X ((= num 48.) '*c48*)
X ((= num 49.) '*c49*)
X ((= num 50.) '*c50*)
X ((= num 51.) '*c51*)
X ((= num 52.) '*c52*)
X ((= num 53.) '*c53*)
X ((= num 54.) '*c54*)
X ((= num 55.) '*c55*)
X ((= num 56.) '*c56*)
X ((= num 57.) '*c57*)
X ((= num 58.) '*c58*)
X ((= num 59.) '*c59*)
X ((= num 60.) '*c60*)
X ((= num 61.) '*c61*)
X ((= num 62.) '*c62*)
X ((= num 63.) '*c63*)
X ((= num 64.) '*c64*)
X (t (%error '|condition is too long| (rest-of-ce)))))
X
X
X;;; Compiling variables
X;
X;
X;
X; *cur-vars* are the variables in the condition element currently
X; being compiled. *vars* are the variables in the earlier condition
X; elements. *ce-vars* are the condition element variables. note
X; that the interpreter will not confuse condition element and regular
X; variables even if they have the same name.
X;
X; *cur-vars* is a list of triples: (name predicate subelement-number)
X; eg: ( (<x> eq 3)
X; (<y> ne 1)
X; . . . )
X;
X; *vars* is a list of triples: (name ce-number subelement-number)
X; eg: ( (<x> 3 3)
X; (<y> 1 1)
X; . . . )
X;
X; *ce-vars* is a list of pairs: (name ce-number)
X; eg: ( (ce1 1)
X; (<c3> 3)
X; . . . )
X
X(defun var-dope (var) (assq var *vars*))
X
X(defun ce-var-dope (var) (assq var *ce-vars*))
X
X(defun cmp-var (test)
X (prog (old name)
X (setq name (sublex))
X (setq old (assq name *cur-vars*))
X (cond ((and old (eq (cadr old) 'eq))
X (cmp-old-eq-var test old))
X ((and old (eq test 'eq)) (cmp-new-eq-var name old))
X (t (cmp-new-var name test)))))
X
X(defun cmp-new-var (name test)
X (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*)))
X
X(defun cmp-old-eq-var (test old)
X (link-new-node (list (concat3 't test 's)
X nil
X (current-field)
X (field-name (caddr old)))))
X
X(defun cmp-new-eq-var (name old)
X (prog (pred next)
X (setq *cur-vars* (delq old *cur-vars*))
X (setq next (assq name *cur-vars*))
X (cond (next (cmp-new-eq-var name next))
X (t (cmp-new-var name 'eq)))
X (setq pred (cadr old))
X (link-new-node (list (concat3 't pred 's)
X nil
X (field-name (caddr old))
X (current-field)))))
X
X(defun cmp-cevar nil
X (prog (name old)
X (setq name (lex))
X (setq old (assq name *ce-vars*))
X (and old
X (%error '|condition element variable used twice| name))
X (setq *ce-vars* (cons (list name 0.) *ce-vars*))))
X
X(defun cmp-not nil (cmp-beta '¬))
X
X(defun cmp-nobeta nil (cmp-beta nil))
X
X(defun cmp-and nil (cmp-beta '&and))
X
X(defun cmp-beta (kind)
X (prog (tlist vdope vname vpred vpos old)
X (setq tlist nil)
X la (and (atom *cur-vars*) (go lb))
X (setq vdope (car *cur-vars*))
X (setq *cur-vars* (cdr *cur-vars*))
X (setq vname (car vdope))
X (setq vpred (cadr vdope))
X (setq vpos (caddr vdope))
X (setq old (assq vname *vars*))
X (cond (old (setq tlist (add-test tlist vdope old)))
X ((neq kind '¬) (promote-var vdope)))
X (go la)
X lb (and kind (build-beta kind tlist))
X (or (eq kind '¬) (fudge))
X (setq *last-branch* *last-node*)))
X
X(defun add-test (list new old)
X (prog (ttype lloc rloc)
X (setq *feature-count* (1+ *feature-count*))
X (setq ttype (concat3 't (cadr new) 'b))
X (setq rloc (encode-singleton (caddr new)))
X (setq lloc (encode-pair (cadr old) (caddr old)))
X (return (cons ttype (cons lloc (cons rloc list))))))
X
X; the following two functions encode indices so that gelm can
X; decode them as fast as possible
X
X(defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b)))
X
X(defun encode-singleton (a) (1- a))
X
X(defun promote-var (dope)
X (prog (vname vpred vpos new)
X (setq vname (car dope))
X (setq vpred (cadr dope))
X (setq vpos (caddr dope))
X (or (eq 'eq vpred)
X (%error '|illegal predicate for first occurrence|
X (list vname vpred)))
X (setq new (list vname 0. vpos))
X (setq *vars* (cons new *vars*))))
X
X(defun fudge nil
X (mapc (function fudge*) *vars*)
X (mapc (function fudge*) *ce-vars*))
X
X(defun fudge* (z)
X (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a)))))
X
X(defun build-beta (type tests)
X (prog (rpred lpred lnode lef)
X (link-new-node (list '&mem nil nil (protomem)))
X (setq rpred *last-node*)
X (cond ((eq type '&and)
X (setq lnode (list '&mem nil nil (protomem))))
X (t (setq lnode (list '&two nil nil))))
X (setq lpred (link-to-branch lnode))
X (cond ((eq type '&and) (setq lef lpred))
X (t (setq lef (protomem))))
X (link-new-beta-node (list type nil lef rpred tests))))
X
X(defun protomem nil (list nil))
X
X(defun memory-part (mem-node) (car (cadddr mem-node)))
X
X(defun encode-dope nil
X (prog (r all z k)
X (setq r nil)
X (setq all *vars*)
X la (and (atom all) (return r))
X (setq z (car all))
X (setq all (cdr all))
X (setq k (encode-pair (cadr z) (caddr z)))
X (setq r (cons (car z) (cons k r)))
X (go la)))
X
X(defun encode-ce-dope nil
X (prog (r all z k)
X (setq r nil)
X (setq all *ce-vars*)
X la (and (atom all) (return r))
X (setq z (car all))
X (setq all (cdr all))
X (setq k (cadr z))
X (setq r (cons (car z) (cons k r)))
X (go la)))
X
X
X
X;;; Linking the nodes
X
X(defun link-new-node (r)
X (cond ((not (member (car r) '(&p &mem &two &and ¬)))
X (setq *feature-count* (1+ *feature-count*))))
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-node* (link-left *last-node* r)))
X
X(defun link-to-branch (r)
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-branch* (link-left *last-branch* r)))
X
X(defun link-new-beta-node (r)
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-node* (link-both *last-branch* *last-node* r))
X (setq *last-branch* *last-node*))
X
X(defun link-left (pred succ)
X (prog (a r)
X (setq a (left-outs pred))
X (setq r (find-equiv-node succ a))
X (and r (return r))
X (setq *real-cnt* (1+ *real-cnt*))
X (attach-left pred succ)
X (return succ)))
X
X(defun link-both (left right succ)
X (prog (a r)
X (setq a (interq (left-outs left) (right-outs right)))
X (setq r (find-equiv-beta-node succ a))
X (and r (return r))
X (setq *real-cn (sublex))
X ((eq x '<=) (setq test 'le) (sublex))
X ((eq x '>) (setq test 'gt) (sublex))
X ((eq x '>=) (setq test 'ge) (sublex))
X ((eq x '<=>) (setq test 'xx) (sublex))
X (t (setq test 'eq)))
X (cmp-symbol test)))
X
X(defun cmp-product nil
X (prog (save)
X (setq save (rest-of-ce))
X (sublex)
X la (cond ((end-of-ce)
X (cond ((member #\} save)
X (%error '|wrong contex for '}'| save))
X (t (%error '|missing '}'| save))))
X ((eq (peek-sublex) #\}) (sublex) (return nil)))
X (cmp-atomic-or-any)
X (go la)))
X
X(defun variablep (x) (and (symbolp x) (char-equal (char (symbol-name x) 0) #\<)))
X
X(defun cmp-symbol (test)
X (prog (flag)
X (setq flag t)
X (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
X (cond ((and flag (variablep (peek-sublex)))
X (cmp-var test))
X ((numberp (peek-sublex)) (cmp-number test))
X ((symbolp (peek-sublex)) (cmp-constant test))
X (t (%error '|unrecognized symbol| (sublex))))))
X
X(defun concat3(x y z)
X (intern (format nil "~s~s~s" x y z)))
X
X(defun cmp-constant (test)
X (or (memq test '(eq ne xx))
X (%error '|non-numeric constant after numeric predicate| (sublex)))
X (link-new-node (list (concat3 't test 'a)
X nil
X (current-field)
X (sublex))))
X
X
X(defun cmp-number (test)
X (link-new-node (list (concat3 't test 'n)
X nil
X (current-field)
X (sublex))))
X
X(defun current-field nil (field-name *subnum*))
X
X(defun field-name (num)
X (cond ((= num 1.) '*c1*)
X ((= num 2.) '*c2*)
X ((= num 3.) '*c3*)
X ((= num 4.) '*c4*)
X ((= num 5.) '*c5*)
X ((= num 6.) '*c6*)
X ((= num 7.) '*c7*)
X ((= num 8.) '*c8*)
X ((= num 9.) '*c9*)
X ((= num 10.) '*c10*)
X ((= num 11.) '*c11*)
X ((= num 12.) '*c12*)
X ((= num 13.) '*c13*)
X ((= num 14.) '*c14*)
X ((= num 15.) '*c15*)
X ((= num 16.) '*c16*)
X ((= num 17.) '*c17*)
X ((= num 18.) '*c18*)
X ((= num 19.) '*c19*)
X ((= num 20.) '*c20*)
X ((= num 21.) '*c21*)
X ((= num 22.) '*c22*)
X ((= num 23.) '*c23*)
X ((= num 24.) '*c24*)
X ((= num 25.) '*c25*)
X ((= num 26.) '*c26*)
X ((= num 27.) '*c27*)
X ((= num 28.) '*c28*)
X ((= num 29.) '*c29*)
X ((= num 30.) '*c30*)
X ((= num 31.) '*c31*)
X ((= num 32.) '*c32*)
X ((= num 33.) '*c33*)
X ((= num 34.) '*c34*)
X ((= num 35.) '*c35*)
X ((= num 36.) '*c36*)
X ((= num 37.) '*c37*)
X ((= num 38.) '*c38*)
X ((= num 39.) '*c39*)
X ((= num 40.) '*c40*)
X ((= num 41.) '*c41*)
X ((= num 42.) '*c42*)
X ((= num 43.) '*c43*)
X ((= num 44.) '*c44*)
X ((= num 45.) '*c45*)
X ((= num 46.) '*c46*)
X ((= num 47.) '*c47*)
X ((= num 48.) '*c48*)
X ((= num 49.) '*c49*)
X ((= num 50.) '*c50*)
X ((= num 51.) '*c51*)
X ((= num 52.) '*c52*)
X ((= num 53.) '*c53*)
X ((= num 54.) '*c54*)
X ((= num 55.) '*c55*)
X ((= num 56.) '*c56*)
X ((= num 57.) '*c57*)
X ((= num 58.) '*c58*)
X ((= num 59.) '*c59*)
X ((= num 60.) '*c60*)
X ((= num 61.) '*c61*)
X ((= num 62.) '*c62*)
X ((= num 63.) '*c63*)
X ((= num 64.) '*c64*)
X (t (%error '|condition is too long| (rest-of-ce)))))
X
X
X;;; Compiling variables
X;
X;
X;
X; *cur-vars* are the variables in the condition element currently
X; being compiled. *vars* are the variables in the earlier condition
X; elements. *ce-vars* are the condition element variables. note
X; that the interpreter will not confuse condition element and regular
X; variables even if they have the same name.
X;
X; *cur-vars* is a list of triples: (name predicate subelement-number)
X; eg: ( (<x> eq 3)
X; (<y> ne 1)
X; . . . )
X;
X; *vars* is a list of triples: (name ce-number subelement-number)
X; eg: ( (<x> 3 3)
X; (<y> 1 1)
X; . . . )
X;
X; *ce-vars* is a list of pairs: (name ce-number)
X; eg: ( (ce1 1)
X; (<c3> 3)
X; . . . )
X
X(defun var-dope (var) (assq var *vars*))
X
X(defun ce-var-dope (var) (assq var *ce-vars*))
X
X(defun cmp-var (test)
X (prog (old name)
X (setq name (sublex))
X (setq old (assq name *cur-vars*))
X (cond ((and old (eq (cadr old) 'eq))
X (cmp-old-eq-var test old))
X ((and old (eq test 'eq)) (cmp-new-eq-var name old))
X (t (cmp-new-var name test)))))
X
X(defun cmp-new-var (name test)
X (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*)))
X
X(defun cmp-old-eq-var (test old)
X (link-new-node (list (concat3 't test 's)
X nil
X (current-field)
X (field-name (caddr old)))))
X
X(defun cmp-new-eq-var (name old)
X (prog (pred next)
X (setq *cur-vars* (delq old *cur-vars*))
X (setq next (assq name *cur-vars*))
X (cond (next (cmp-new-eq-var name next))
X (t (cmp-new-var name 'eq)))
X (setq pred (cadr old))
X (link-new-node (list (concat3 't pred 's)
X nil
X (field-name (caddr old))
X (current-field)))))
X
X(defun cmp-cevar nil
X (prog (name old)
X (setq name (lex))
X (setq old (assq name *ce-vars*))
X (and old
X (%error '|condition element variable used twice| name))
X (setq *ce-vars* (cons (list name 0.) *ce-vars*))))
X
X(defun cmp-not nil (cmp-beta '¬))
X
X(defun cmp-nobeta nil (cmp-beta nil))
X
X(defun cmp-and nil (cmp-beta '&and))
X
X(defun cmp-beta (kind)
X (prog (tlist vdope vname vpred vpos old)
X (setq tlist nil)
X la (and (atom *cur-vars*) (go lb))
X (setq vdope (car *cur-vars*))
X (setq *cur-vars* (cdr *cur-vars*))
X (setq vname (car vdope))
X (setq vpred (cadr vdope))
X (setq vpos (caddr vdope))
X (setq old (assq vname *vars*))
X (cond (old (setq tlist (add-test tlist vdope old)))
X ((neq kind '¬) (promote-var vdope)))
X (go la)
X lb (and kind (build-beta kind tlist))
X (or (eq kind '¬) (fudge))
X (setq *last-branch* *last-node*)))
X
X(defun add-test (list new old)
X (prog (ttype lloc rloc)
X (setq *feature-count* (1+ *feature-count*))
X (setq ttype (concat3 't (cadr new) 'b))
X (setq rloc (encode-singleton (caddr new)))
X (setq lloc (encode-pair (cadr old) (caddr old)))
X (return (cons ttype (cons lloc (cons rloc list))))))
X
X; the following two functions encode indices so that gelm can
X; decode them as fast as possible
X
X(defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b)))
X
X(defun encode-singleton (a) (1- a))
X
X(defun promote-var (dope)
X (prog (vname vpred vpos new)
X (setq vname (car dope))
X (setq vpred (cadr dope))
X (setq vpos (caddr dope))
X (or (eq 'eq vpred)
X (%error '|illegal predicate for first occurrence|
X (list vname vpred)))
X (setq new (list vname 0. vpos))
X (setq *vars* (cons new *vars*))))
X
X(defun fudge nil
X (mapc (function fudge*) *vars*)
X (mapc (function fudge*) *ce-vars*))
X
X(defun fudge* (z)
X (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a)))))
X
X(defun build-beta (type tests)
X (prog (rpred lpred lnode lef)
X (link-new-node (list '&mem nil nil (protomem)))
X (setq rpred *last-node*)
X (cond ((eq type '&and)
X (setq lnode (list '&mem nil nil (protomem))))
X (t (setq lnode (list '&two nil nil))))
X (setq lpred (link-to-branch lnode))
X (cond ((eq type '&and) (setq lef lpred))
X (t (setq lef (protomem))))
X (link-new-beta-node (list type nil lef rpred tests))))
X
X(defun protomem nil (list nil))
X
X(defun memory-part (mem-node) (car (cadddr mem-node)))
X
X(defun encode-dope nil
X (prog (r all z k)
X (setq r nil)
X (setq all *vars*)
X la (and (atom all) (return r))
X (setq z (car all))
X (setq all (cdr all))
X (setq k (encode-pair (cadr z) (caddr z)))
X (setq r (cons (car z) (cons k r)))
X (go la)))
X
X(defun encode-ce-dope nil
X (prog (r all z k)
X (setq r nil)
X (setq all *ce-vars*)
X la (and (atom all) (return r))
X (setq z (car all))
X (setq all (cdr all))
X (setq k (cadr z))
X (setq r (cons (car z) (cons k r)))
X (go la)))
X
X
X
X;;; Linking the nodes
X
X(defun link-new-node (r)
X (cond ((not (member (car r) '(&p &mem &two &and ¬)))
X (setq *feature-count* (1+ *feature-count*))))
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-node* (link-left *last-node* r)))
X
X(defun link-to-branch (r)
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-branch* (link-left *last-branch* r)))
X
X(defun link-new-beta-node (r)
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-node* (link-both *last-branch* *last-node* r))
X (setq *last-branch* *last-node*))
X
X(defun link-left (pred succ)
X (prog (a r)
X (setq a (left-outs pred))
X (setq r (find-equiv-node succ a))
X (and r (return r))
X (setq *real-cnt* (1+ *real-cnt*))
X (attach-left pred succ)
X (return succ)))
X
X(defun link-both (left right succ)
X (prog (a r)
X (setq a (interq (left-outs left) (right-outs right)))
X (setq r (find-equiv-beta-node succ a))
X (and r (return r))
X (setq *real-cnt* (1+ *real-cnt*))
X (attach-left left succ)
X (attach-right right succ)
X (return succ)))
X
X(defun attach-right (old new)
X (rplaca (cddr old) (cons new (caddr old))))
X
X(defun attach-left (old new)
X (rplaca (cdr old) (cons new (cadr old))))
X
X(defun right-outs (node) (caddr node))
X
X(defun left-outs (node) (cadr node))
X
X(defun find-equiv-node (node list)
X (prog (a)
X (setq a list)
X l1 (cond ((atom a) (return nil))
X ((equiv node (car a)) (return (car a))))
X (setq a (cdr a))
X (go l1)))
X
X(defun find-equiv-beta-node (node list)
X (prog (a)
X (setq a list)
X l1 (cond ((atom a) (return nil))
X ((beta-equiv node (car a)) (return (car a))))
X (setq a (cdr a))
X (go l1)))
X
X; do not look at the predecessor fields of beta nodes; they have to be
X; identical because of the way the candidate nodes were found
X
X(defun equiv (a b)
X (and (eq (car a) (car b))
X (or (eq (car a) '&mem)
X (eq (car a) '&two)
X (equal (caddr a) (caddr b)))
X (equal (cdddr a) (cdddr b))))
X
X(defun beta-equiv (a b)
X (and (eq (car a) (car b))
X (equal (cddddr a) (cddddr b))
X (or (eq (car a) '&and) (equal (caddr a) (caddr b)))))
X
X; the equivalence tests are set up to consider the contents of
X; node memories, so they are ready for the build action
X
X;;; Network interpreter
X
X(defun match (flag wme)
X (sendto flag (list wme) 'left (list *first-node*)))
X
X; note that eval-nodelist is not set up to handle building
X; productions. would have to add something like ops4's build-flag
X
X(defun eval-nodelist (nl)
X (prog nil
X top (and (not nl) (return nil))
X (setq *sendtocall* nil)
X (setq *last-node* (car nl))
X (apply (caar nl) (cdar nl))
X (setq nl (cdr nl))
X (go top)))
X
X(defun sendto (flag data side nl)
X (prog nil
X top (and (not nl) (return nil))
X (setq *side* side)
X (setq *flag-part* flag)
X (setq *data-part* data)
X (setq *sendtocall* t)
X (setq *last-node* (car nl))
X (apply (caar nl) (cdar nl))
X (setq nl (cdr nl))
X (go top)))
X
X; &bus sets up the registers for the one-input nodes. note that this
X(defun &bus (outs)
X (prog (dp)
X (setq *alpha-flag-part* *flag-part*)
X (setq *alpha-data-part* *data-part*)
X (setq dp (car *data-part*))
X (setq *c1* (car dp))
X (setq dp (cdr dp))
X (setq *c2* (car dp))
X (setq dp (cdr dp))
X (setq *c3* (car dp))
X (setq dp (cdr dp))
X (setq *c4* (car dp))
X (setq dp (cdr dp))
X (setq *c5* (car dp))
X (setq dp (cdr dp))
X (setq *c6* (car dp))
X (setq dp (cdr dp))
X (setq *c7* (car dp))
X (setq dp (cdr dp))
X (setq *c8* (car dp))
X (setq dp (cdr dp))
X (setq *c9* (car dp))
X (setq dp (cdr dp))
X (setq *c10* (car dp))
X (setq dp (cdr dp))
X (setq *c11* (car dp))
X (setq dp (cdr dp))
X (setq *c12* (car dp))
X (setq dp (cdr dp))
X (setq *c13* (car dp))
X (setq dp (cdr dp))
X (setq *c14* (car dp))
X (setq dp (cdr dp))
X (setq *c15* (car dp))
X (setq dp (cdr dp))
X (setq *c16* (car dp))
X (setq dp (cdr dp))
X (setq *c17* (car dp))
X (setq dp (cdr dp))
X (setq *c18* (car dp))
X (setq dp (cdr dp))
X (setq *c19* (car dp))
X (setq dp (cdr dp))
X (setq *c20* (car dp))
X (setq dp (cdr dp))
X (setq *c21* (car dp))
X (setq dp (cdr dp))
X (setq *c22* (car dp))
X (setq dp (cdr dp))
X (setq *c23* (car dp))
X (setq dp (cdr dp))
X (setq *c24* (car dp))
X (setq dp (cdr dp))
X (setq *c25* (car dp))
X (setq dp (cdr dp))
X (setq *c26* (car dp))
X (setq dp (cdr dp))
X (setq *c27* (car dp))
X (setq dp (cdr dp))
X (setq *c28* (car dp))
X (setq dp (cdr dp))
X (setq *c29* (car dp))
X (setq dp (cdr dp))
X (setq *c30* (car dp))
X (setq dp (cdr dp))
X (setq *c31* (car dp))
X (setq dp (cdr dp))
X (setq *c32* (car dp))
X (setq dp (cdr dp))
X (setq *c33* (car dp))
X (setq dp (cdr dp))
X (setq *c34* (car dp))
X (setq dp (cdr dp))
X (setq *c35* (car dp))
X (setq dp (cdr dp))
X (setq *c36* (car dp))
X (setq dp (cdr dp))
X (setq *c37* (car dp))
X (setq dp (cdr dp))
X (setq *c38* (car dp))
X (setq dp (cdr dp))
X (setq *c39* (car dp))
X (setq dp (cdr dp))
X (setq *c40* (car dp))
X (setq dp (cdr dp))
X (setq *c41* (car dp))
X (setq dp (cdr dp))
X (setq *c42* (car dp))
X (setq dp (cdr dp))
X (setq *c43* (car dp))
X (setq dp (cdr dp))
X (setq *c44* (car dp))
X (setq dp (cdr dp))
X (setq *c45* (car dp))
X (setq dp (cdr dp))
X (setq *c46* (car dp))
X (setq dp (cdr dp))
X (setq *c47* (car dp))
X (setq dp (cdr dp))
X (setq *c48* (car dp))
X (setq dp (cdr dp))
X (setq *c49* (car dp))
X (setq dp (cdr dp))
X (setq *c50* (car dp))
X (setq dp (cdr dp))
X (setq *c51* (car dp))
X (setq dp (cdr dp))
X (setq *c52* (car dp))
X (setq dp (cdr dp))
X (setq *c53* (car dp))
X (setq dp (cdr dp))
X (setq *c54* (car dp))
X (setq dp (cdr dp))
X (setq *c55* (car dp))
X (setq dp (cdr dp))
X (setq *c56* (car dp))
X (setq dp (cdr dp))
X (setq *c57* (car dp))
X (setq dp (cdr dp))
X (setq *c58* (car dp))
X (setq dp (cdr dp))
X (setq *c59* (car dp))
X (setq dp (cdr dp))
X (setq *c60* (car dp))
X (setq dp (cdr dp))
X (setq *c61* (car dp))
X (setq dp (cdr dp))
X (setq *c62* (car dp))
X (setq dp (cdr dp))
X (setq *c63* (car dp))
X (setq dp (cdr dp))
X (setq *c64* (car dp))
X (eval-nodelist outs)))
X
X(defun &any (outs register const-list)
X (prog (z c)
X (setq z (fast-symeval register))
X (cond ((numberp z) (go number)))
X symbol (cond ((null const-list) (return nil))
X ((eq (car const-list) z) (go ok))
X (t (setq const-list (cdr const-list)) (go symbol)))
X number (cond ((null const-list) (return nil))
X ((and (numberp (setq c (car const-list)))
X (=alg c turner@imagen.UUCP (D'arc Angel) (01/19/87)
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X (comment the next line differs in not-left & -right)
X (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
X (cond (res (go tloop))
X (t (setq mem (cddr mem)) (go fail)))
X succ (setq newc (+ inc newc))
X (rplaca (cdr mem) newc)
X (cond ((or (and (== inc -1.) (== newc 0.))
X (and (== inc 1.) (== newc 1.)))
X (sendto newfp memdp 'right outs)))
X (setq mem (cddr mem))
X (go fail)))
X
X
X
X;;; Node memories
X
X
X(defun add-token (memlis flag data-part num)
X (prog (was-present)
X (cond ((eq flag 'new)
X (setq was-present nil)
X (real-add-token memlis data-part num))
X ((not flag)
X (setq was-present (remove-old memlis data-part num)))
X ((eq flag 'old) (setq was-present t)))
X (return was-present)))
X
X(defun real-add-token (lis data-part num)
X (setq *current-token* (1+ *current-token*))
X (cond (num (rplaca lis (cons num (car lis)))))
X (rplaca lis (cons data-part (car lis))))
X
X(defun remove-old (lis data num)
X (cond (num (remove-old-num lis data))
X (t (remove-old-no-num lis data))))
X
X(defun remove-old-num (lis data)
X (prog (m next last)
X (setq m (car lis))
X (cond ((atom m) (return nil))
X ((top-levels-eq data (car m))
X (setq *current-token* (1- *current-token*))
X (rplaca lis (cddr m))
X (return (car m))))
X (setq next m)
X loop (setq last next)
X (setq next (cddr next))
X (cond ((atom next) (return nil))
X ((top-levels-eq data (car next))
X (rplacd (cdr last) (cddr next))
X (setq *current-token* (1- *current-token*))
X (return (car next)))
X (t (go loop)))))
X
X(defun remove-old-no-num (lis data)
X (prog (m next last)
X (setq m (car lis))
X (cond ((atom m) (return nil))
X ((top-levels-eq data (car m))
X (setq *current-token* (1- *current-token*))
X (rplaca lis (cdr m))
X (return (car m))))
X (setq next m)
X loop (setq last next)
X (setq next (cdr next))
X (cond ((atom next) (return nil))
X ((top-levels-eq data (car next))
X (rplacd last (cdr next))
X (setq *current-token* (1- *current-token*))
X (return (car next)))
X (t (go loop)))))
X
X
X
X;;; Conflict Resolution
X;
X;
X; each conflict set element is a list of the following form:
X; ((p-name . data-part) (sorted wm-recency) special-case-number)
X
X(defun removecs (name data)
X (prog (cr-data inst cs)
X (setq cr-data (cons name data))
X (setq cs *conflict-set*)
X loop1 (cond ((null cs)
X (record-refract name data)
X (return nil)))
X (setq inst (car cs))
X (setq cs (cdr cs))
X (and (not (top-levels-eq (car inst) cr-data)) (go loop1))
X (setq *conflict-set* (delq inst *conflict-set*))))
X
X(defun insertcs (name data rating)
X (prog (instan)
X (and (refracted name data) (return nil))
X (setq instan (list (cons name data) (order-tags data) rating))
X (and (atom *conflict-set*) (setq *conflict-set* nil))
X (return (setq *conflict-set* (cons instan *conflict-set*)))))
X
X(defun order-tags (dat)
X (prog (tags)
X (setq tags nil)
X l1 (and (atom dat) (go l2))
X (setq tags (cons (creation-time (car dat)) tags))
X (setq dat (cdr dat))
X (go l1)
X l2 (cond ((eq *strategy* 'mea)
X (return (cons (car tags) (dsort (cdr tags)))))
X (t (return (dsort tags))))))
X
X; destructively sort x into descending order
X
X(defun dsort (x)
X (prog (sorted cur next cval nval)
X (and (atom (cdr x)) (return x))
X loop (setq sorted t)
X (setq cur x)
X (setq next (cdr x))
X chek (setq cval (car cur))
X (setq nval (car next))
X (cond ((> nval cval)
X (setq sorted nil)
X (rplaca cur nval)
X (rplaca next cval)))
X (setq cur next)
X (setq next (cdr cur))
X (cond ((not (null next)) (go chek))
X (sorted (return x))
X (t (go loop)))))
X
X(defun conflict-resolution nil
X (prog (best len)
X (setq len (length *conflict-set*))
X (cond ((> len *max-cs*) (setq *max-cs* len)))
X (setq *total-cs* (+ *total-cs* len))
X (cond (*conflict-set*
X (setq best (best-of *conflict-set*))
X (setq *conflict-set* (delq best *conflict-set*))
X (return (pname-instantiation best)))
X (t (return nil)))))
X
X(defun best-of (set) (best-of* (car set) (cdr set)))
X
X(defun best-of* (best rem)
X (cond ((not rem) best)
X ((conflict-set-compare best (car rem))
X (best-of* best (cdr rem)))
X (t (best-of* (car rem) (cdr rem)))))
X
X(defun remove-from-conflict-set (name)
X (prog (cs entry)
X l1 (setq cs *conflict-set*)
X l2 (cond ((atom cs) (return nil)))
X (setq entry (car cs))
X (setq cs (cdr cs))
X (cond ((eq name (caar entry))
X (setq *conflict-set* (delq entry *conflict-set*))
X (go l1))
X (t (go l2)))))
X
X(defun pname-instantiation (conflict-elem) (car conflict-elem))
X
X(defun order-part (conflict-elem) (cdr conflict-elem))
X
X(defun instantiation (conflict-elem)
X (cdr (pname-instantiation conflict-elem)))
X
X
X(defun conflict-set-compare (x y)
X (prog (x-order y-order xl yl xv yv)
X (setq x-order (order-part x))
X (setq y-order (order-part y))
X (setq xl (car x-order))
X (setq yl (car y-order))
X data (cond ((and (null xl) (null yl)) (go ps))
X ((null yl) (return t))
X ((null xl) (return nil)))
X (setq xv (car xl))
X (setq yv (car yl))
X (cond ((> xv yv) (return t))
X ((> yv xv) (return nil)))
X (setq xl (cdr xl))
X (setq yl (cdr yl))
X (go data)
X ps (setq xl (cdr x-order))
X (setq yl (cdr y-order))
X psl (cond ((null xl) (return t)))
X (setq xv (car xl))
X (setq yv (car yl))
X (cond ((> xv yv) (return t))
X ((> yv xv) (return nil)))
X (setq xl (cdr xl))
X (setq yl (cdr yl))
X (go psl)))
X
X
X(defun conflict-set nil
X (prog (cnts cs p z best)
X (setq cnts nil)
X (setq cs *conflict-set*)
X l1 (and (atom cs) (go l2))
X (setq p (caaar cs))
X (setq cs (cdr cs))
X (setq z (assq p cnts))
X (cond ((null z) (setq cnts (cons (cons p 1.) cnts)))
X (t (rplacd z (1+ (cdr z)))))
X (go l1)
X l2 (cond ((atom cnts)
X (setq best (best-of *conflict-set*))
X (terpri)
X (return (list (caar best) 'dominates))))
X (terpri)
X (princ (caar cnts))
X (cond ((> (cdar cnts) 1.)
X (princ '| (|)
X (princ (cdar cnts))
X (princ '| occurrences)|)))
X (setq cnts (cdr cnts))
X (go l2)))
X
X
X
X;;; WM maintaining functions
X;
X; The order of operations in the following two functions is critical.
X; add-to-wm order: (1) change wm (2) record change (3) match
X; remove-from-wm order: (1) record change (2) match (3) change wm
X; (back will not restore state properly unless wm changes are recorded
X; before the cs changes that they cause) (match will give errors if
X; the thing matched is not in wm at the time)
X
X
X(defun add-to-wm (wme override)
X (prog (fa z part timetag port)
X (setq *critical* t)
X (setq *current-wm* (1+ *current-wm*))
X (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
X (setq *action-count* (1+ *action-count*))
X (setq fa (wm-hash wme))
X (or (memq fa *wmpart-list*)
X (setq *wmpart-list* (cons fa *wmpart-list*)))
X (setq part (get fa 'wmpart*))
X (cond (override (setq timetag override))
X (t (setq timetag *action-count*)))
X (setq z (cons wme timetag))
X (putprop fa (cons z part) 'wmpart*)
X (record-change '=>wm *action-count* wme)
X (match 'new wme)
X (setq *critical* nil)
X (cond ((and *in-rhs* *wtrace*)
X (setq port (trace-file))
X (terpri port)
X (princ '|=>wm: | port)
X (ppelm wme port)))
X (and *in-rhs* *mtrace* (setq *madeby*
X (cons (cons wme *p-name*) *madeby*)))))
X
X; remove-from-wm uses eq, not equal to determine if wme is present
X
X(defun remove-from-wm (wme)
X (prog (fa z part timetag port)
X (setq fa (wm-hash wme))
X (setq part (get fa 'wmpart*))
X (setq z (assq wme part))
X (or z (return nil))
X (setq timetag (cdr z))
X (cond ((and *wtrace* *in-rhs*)
X (setq port (trace-file))
X (terpri port)
X (princ '|<=wm: | port)
X (ppelm wme port)))
X (setq *action-count* (1+ *action-count*))
X (setq *critical* t)
X (setq *current-wm* (1- *current-wm*))
X (record-change '<=wm timetag wme)
X (match nil wme)
X (putprop fa (delq z part) 'wmpart* )
X (setq *critical* nil)))
X
X; mapwm maps down the elements of wm, applying fn to each element
X; each element is of form (datum . creation-time)
X
X(defun mapwm (fn)
X (prog (wmpl part)
X (setq wmpl *wmpart-list*)
X lab1 (cond ((atom wmpl) (return nil)))
X (setq part (get (car wmpl) 'wmpart*))
X (setq wmpl (cdr wmpl))
X (mapc fn part)
X (go lab1)))
X
X(defun wm ("e &rest a)
X (mapc (function (lambda (z) (terpri) (ppelm z t)))
X (get-wm a))
X nil)
X
X(defun get-wm (z)
X (setq *wm-filter* z)
X (setq *wm* nil)
X (mapwm (function get-wm2))
X (prog2 nil *wm* (setq *wm* nil)))
X
X(defun get-wm2 (elem)
X (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*))
X (setq *wm* (cons (car elem) *wm*)))))
X
X(defun wm-hash (x)
X (cond ((not x) '<default>)
X ((not (car x)) (wm-hash (cdr x)))
X ((symbolp (car x)) (car x))
X (t (wm-hash (cdr x)))))
X
X(defun creation-time (wme)
X (cdr (assq wme (get (wm-hash wme) 'wmpart*))))
X
X(defun rehearse nil
X (prog nil
X (setq *old-wm* nil)
X (mapwm (function refresh-collect))
X (mapc (function refresh-del) *old-wm*)
X (mapc (function refresh-add) *old-wm*)
X (setq *old-wm* nil)))
X
X(defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*)))
X
X(defun refresh-del (x) (remove-from-wm (car x)))
X
X(defun refresh-add (x) (add-to-wm (car x) (cdr x)))
X
X(defun trace-file ()
X (prog (port)
X (setq port t)
X (cond (*trace-file*
X (setq port ($ofile *trace-file*))
X (cond ((null port)
X (%warn '|trace: file has been closed| *trace-file*)
X (setq port t)))))
X (return port)))
X
X
X;;; Basic functions for RHS evaluation
X
X(defun eval-rhs (pname data)
X (prog (node port)
X (cond (*ptrace*
X (setq port (trace-file))
X (terpri port)
X (princ *cycle-count* port)
X (princ '|. | port)
X (princ pname port)
X (time-tag-print data port)))
X (setq *data-matched* data)
X (setq *p-name* pname)
X (setq *last* nil)
X (setq node (get pname 'topnode))
X (init-var-mem (var-part node))
X (init-ce-var-mem (ce-var-part node))
X (begin-record pname data)
X (setq *in-rhs* t)
X (eval (rhs-part node))
X (setq *in-rhs* nil)
X (end-record)))
X
X(defun time-tag-print (data port)
X (cond ((not (null data))
X (time-tag-print (cdr data) port)
X (princ '| | port)
X (princ (creation-time (car data)) port))))
X
X(defun init-var-mem (vlist)
X (prog (v ind r)
X (setq *variable-memory* nil)
X top (and (atom vlist) (return nil))
X (setq v (car vlist))
X (setq ind (cadr vlist))
X (setq vlist (cddr vlist))
X (setq r (gelm *data-matched* ind))
X (setq *variable-memory* (cons (cons v r) *variable-memory*))
X (go top)))
X
X(defun init-ce-var-mem (vlist)
X (prog (v ind r)
X (setq *ce-variable-memory* nil)
X top (and (atom vlist) (return nil))
X (setq v (car vlist))
X (setq ind (cadr vlist))
X (setq vlist (cddr vlist))
X (setq r (ce-gelm *data-matched* ind))
X (setq *ce-variable-memory*
X (cons (cons v r) *ce-variable-memory*))
X (go top)))
X
X(defun make-ce-var-bind (var elem)
X (setq *ce-variable-memory*
X (cons (cons var elem) *ce-variable-memory*)))
X
X(defun make-var-bind (var elem)
X (setq *variable-memory* (cons (cons var elem) *variable-memory*)))
X
X(defun $varbind (x)
X (prog (r)
X (and (not *in-rhs*) (return x))
X (setq r (assq x *variable-memory*))
X (cond (r (return (cdr r)))
X (t (return x)))))
X
X(defun get-ce-var-bind (x)
X (prog (r)
X (cond ((numberp x) (return (get-num-ce x))))
X (setq r (assq x *ce-variable-memory*))
X (cond (r (return (cdr r)))
X (t (return nil)))))
X
X(defun get-num-ce (x)
X (prog (r l d)
X (setq r *data-matched*)
X (setq l (length r))
X (setq d (- l x))
X (and (> 0. d) (return nil))
X la (cond ((null r) (return nil))
X ((> 1. d) (return (car r))))
X (setq d (1- d))
X (setq r (cdr r))
X (go la)))
X
X
X(defun build-collect (z)
X (prog (r)
X la (and (atom z) (return nil))
X (setq r (car z))
X (setq z (cdr z))
X (cond ((and r (listp r))
X ($value '\()
X (build-collect r)
X ($value '\)))
X ((eq r '\\) ($change (car z)) (setq z (cdr z)))
X (t ($value r)))
X (go la)))
X
X(defun unflat (x) (setq *rest* x) (unflat*))
X
X(defun unflat* nil
X (prog (c)
X (cond ((atom *rest*) (return nil)))
X (setq c (car *rest*))
X (setq *rest* (cdr *rest*))
X (cond ((eq c '\() (return (cons (unflat*) (unflat*))))
X ((eq c '\)) (return nil))
X (t (return (cons c (unflat*)))))))
X
X
X(defun $change (x)
X (prog nil
X (cond ((and x (listp x)) (eval-function x)) ;modified to check for nil
X (t ($value ($varbind x))))))
X
X(defun eval-args (z)
X (prog (r)
X (rhs-tab 1.)
X la (and (atom z) (return nil))
X (setq r (car z))
X (setq z (cdr z))
X (cond ((eq r #\^)
X (rhs-tab (car z))
X (setq r (cadr z))
X (setq z (cddr z))))
X (cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
X (t ($change r)))
X (go la)))
X
X
X(defun eval-function (form)
X (cond ((not *in-rhs*)
X (%warn '|functions cannot be used at top level| (car form)))
X (t (eval form))))
X
X
X;;; Functions to manipulate the result array
X
X
X(defun $reset nil
X (setq *max-index* 0)
X (setq *next-index* 1))
X
X; rhs-tab implements the tab ('^') function in the rhs. it has
X; four responsibilities:
X; - to move the array pointers
X; - to watch for tabbing off the left end of the array
X; (ie, to watch for pointers less than 1)
X; - to watch for tabbing off the right end of the array
X; - to write nil in all the slots that are skipped
X; the last is necessary if the result array is not to be cleared
X; after each use; if rhs-tab did not do this, $reset
X; would be much slower.
X
X(defun rhs-tab (z) ($tab ($varbind z)))
X
X(defun $tab (z)
X (prog (edge next)
X (setq next ($litbind z))
X (and (floatp next) (setq next (fix next)))
X (cond ((or (not (numberp next))
X (> next *size-result-array*)
X (> 1. next))
X (%warn '|illegal index after ^| next)
X (return *next-index*)))
X (setq edge (- next 1.))
X (cond ((> *max-index* edge) (go ok)))
X clear (cond ((== *max-index* edge) (go ok)))
X (putvector *result-array* edge nil)
X (setq edge (1- edge))
X (go clear)
X ok (setq *next-index* next)
X (return next)))
X
X(defun $value (v)
X (cond ((> *next-index* *size-result-array*)
X (%warn '|index too large| *next-index*))
X (t
X (and (> *next-index* *max-index*)
X (setq *max-index* *next-index*))
X (putvector *result-array* *next-index* v)
X (setq *next-index* (1+ *next-index*)))))
X
X(defun use-result-array nil
X (prog (k r)
X (setq k *max-index*)
X (setq r nil)
X top (and (== k 0.) (return r))
X (setq r (cons (getvector *result-array* k) r))
X (setq k (1- k))
X (go top)))
X
X(defun $assert nil
X (setq *last* (use-result-array))
X (add-to-wm *last* nil))
X
X(defun $parametercount nil *max-index*)
X
X(defun $parameter (k)
X (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
X (%warn '|illegal parameter number | k)
X nil)
X ((> k *max-index*) nil)
X (t (getvector *result-array* k))))
X
X
X;;; RHS actions
X
X(defun make ("e &rest z)
X (prog nil
X ($reset)
X (eval-args z)
X ($assert)))
X
X(defun modify ("e &rest z)
X (prog (old)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'modify)
X (return nil)))
X (setq old (get-ce-var-bind (car z)))
X (cond ((null old)
X (%warn '|modify: first argument must be an element variable|
X (car z))
X (return nil)))
X (remove-from-wm old)
X (setq z (cdr z))
X ($reset)
X copy (and (atom old) (go fin))
X ($change (car old))
X (setq old (cdr old))
X (go copy)
X fin (eval-args z)
X ($assert)))
X
X(defun bind ("e &rest z)
X (prog (val)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'bind)
X (return nil)))
X (cond ((< (length z) 1.)
X (%warn '|bind: wrong number of arguments to| z)
X (return nil))
X ((not (symbolp (car z)))
X (%warn '|bind: illegal argument| (car z))
X (return nil))
X ((= (length z) 1.) (setq val (gensym)))
X (t ($reset)
X (eval-args (cdr z))
X (setq val ($parameter 1.))))
X (make-var-bind (car z) val)))
X
X(defun cbind ("e &rest z)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'cbind))
X ((not (= (length z) 1.))
X (%warn '|cbind: wrong number of arguments| z))
X ((not (symbolp (car z)))
X (%warn '|cbind: illegal argument| (car z)))
X ((null *last*)
X (%warn '|cbind: nothing added yet| (car z)))
X (t (make-ce-var-bind (car z) *last*))))
X
X(defun oremove ("e &rest z)
X (prog (old)
X (and (not *in-rhs*)(return (top-level-remove z)))
X top (and (atom z) (return nil))
X (setq old (get-ce-var-bind (car z)))
X (cond ((null old)
X (%warn '|remove: argument not an element variable| (car z))
X (return nil)))
X (remove-from-wm old)
X (setq z (cdr z))
X (go top)))
X
X(defun ocall ("e &rest z)
X (prog (f)
X (setq f (car z))
X ($reset)
X (eval-args (cdr z))
X (funcall f)))
X
X(defun owrite ("e &rest z)
X (prog (port max k x needspace)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'write)
X (return nil)))
X ($reset)
X (eval-args z)
X (setq k 1.)
X (setq max ($parametercount))
X (cond ((< max 1.)
X (%warn '|write: nothing to print| z)
X (return nil)))
X (setq port (default-write-file))
X (setq x ($parameter 1.))
X (cond ((and (symbolp x) ($ofile x))
X (setq port ($ofile x))
X (setq k 2.)))
X (setq needspace t)
X la (and (> k max) (return nil))
X (setq x ($parameter k))
X (cond ((eq x '|=== C R L F ===|)
X (setq needspace nil)
X (terpri port))
X ((eq x '|=== R J U S T ===|)
X (setq k (+ 2 k))
X (do-rjust ($parameter (1- k)) ($parameter k) port))
X ((eq x '|=== T A B T O ===|)
X (setq needspace nil)
X (setq k (1+ k))
X (do-tabto ($parameter k) port))
X (t
X (and needspace (princ '| | port))
X (setq needspace t)
X (princ x port)))
X (setq k (1+ k))
X (go la)))
X
X(defun default-write-file ()
X (prog (port)
X (setq port t)
X (cond (*write-file*
X (setq port ($ofile *write-file*))
X (cond ((null port)
X (%warn '|write: file has been closed| *write-file*)
X (setq port t)))))
X (return port)))
X
X
X(defun do-rjust (width value port)
X (prog (size)
X (cond ((eq value '|=== T A B T O ===|)
X (%warn '|rjust cannot precede this function| 'tabto)
X (return nil))
X ((eq value '|=== C R L F ===|)
X (%warn '|rjust cannot precede this function| 'crlf)
X (return nil))
X ((eq value '|=== R J U S T ===|)
X (%warn '|rjust cannot precede this function| 'rjust)
X (return nil)))
X (setq size (flatc value ))
X (cond ((> size width)
X (princ '| | port)
X (princ value port)
X (return nil)))
X (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
X (princ value port)))
X
X(defun do-tabto (col port)
X (eval `(format ,port (concatenate 'string "~" (princ-to-string ,col) "T"))))
X
X; (prog (pos)
X; (setq pos (1+ (nwritn port)))
X; (cond ((> pos col)
X; (terpri port)
X; (setq pos 1)))
X; (do k (- col pos) (1- k) (not (> k 0)) (princ '| | port))
X; (return nil)))
X
X
X(defun halt nil
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'halt))
X (t (setq *halt-flag* t))))
X
X(defun build ("e &rest z)
X (prog (r)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'build)
X (return nil)))
X ($reset)
X (build-collect z)
X (setq r (unflat (use-result-array)))
X (and *build-trace* (funcall *build-trace* r))
X (compile-production (car r) (cdr r))))
X
X(defun infile(file)
X (open file :direction :input))
X
X(defun outfile (file)
X (open file :direction :output))
X
X(defun openfile ("e &rest z)
X (prog (file mode id)
X ($reset)
X (eval-args z)
X (cond ((not (equal ($parametercount) 3.))
X (%warn '|openfile: wrong number of arguments| z)
X (return nil)))
X (setq id ($parameter 1))
X (setq file ($parameter 2))
X (setq mode ($parameter 3))
X (cond ((not (symbolp id))
X (%warn '|openfile: file id must be a symbolic atom| id)
X (return nil))
X ((null id)
X (%warn '|openfile: 'nil' is reserved for the terminal| nil)
X (return nil))
X ((or ($ifile id)($ofile id))
X (%warn '|openfile: name already in use| id)
X (return nil)))
X (cond ((eq mode 'in) (putprop id (infile file) 'inputfile))
X ((eq mode 'out) (putprop id (outfile file) 'outputfile))
X (t (%warn '|openfile: illegal mode| mode)
X (return nil)))
X (return nil)))
X
X(defun $ifile (x)
X (cond ((and x (symbolp x)) (get x 'inputfile))
X (t *standard-input*)))
X
X(defun $ofile (x)
X (cond ((and x (symbolp x)) (get x 'outputfile))
X (t *standard-output*)))
X
X
X(defun closefile ("e &rest z)
X ($reset)
X (eval-args z)
X (mapc (function closefile2) (use-result-array)))
X
X(defun closefile2 (file)
X (prog (port)
X (cond ((not (symbolp file))
X (%warn '|closefile: illegal file identifier| file))
X ((setq port ($ifile file))
X (close port)
X (remprop file 'inputfile))
X ((setq port ($ofile file))
X (close port)
X (remprop file 'outputfile)))
X (return nil)))
X
X(defun default ("e &rest z)
X (prog (file use)
X ($reset)
X (eval-args z)
X (cond ((not (equal ($parametercount) 2.))
X (%warn '|default: wrong number of arguments| z)
X (return nil)))
X (setq file ($parameter 1))
X (setq use ($parameter 2))
X (cond ((not (symbolp file))
X (%warn '|default: illegal file identifier| file)
X (return nil))
X ((not (memq use '(write accept trace)))
X (%warn '|default: illegal use for a file| use)
X (return nil))
X ((and (memq use '(write trace))
X (not (null file))
X (not ($ofile file)))
X (%warn '|default: file has not been opened for output| file)
X (return nil))
X ((and (eq use 'accept)
X (not (null file))
X (not ($ifile file)))
X (%warn '|default: file has not been opened for input| file)
X (return nil))
X ((eq use 'write) (setq *write-file* file))
X ((eq use 'accept) (setq *accept-file* file))
X ((eq use 'trace) (setq *trace-file* file)))
X (return nil)))
X
X
X
X;;; RHS Functions
X
X(defun accept ("e &rest z)
X (prog (port arg)
X (cond ((> (length z) 1.)
X (%warn '|accept: wrong number of arguments| z)
X (return nil)))
X (setq port t)
X (cond (*accept-file*
X (setq port ($ifile *accept-file*))
X (cond ((null port)
X (%warn '|accept: file has been closed| *accept-file*)
X (return nil)))))
X (cond ((= (length z) 1)
X (setq arg ($varbind (car z)))
X (cond ((not (symbolp arg))
X (%warn '|accept: illegal file name| arg)
X (return nil)))
X (setq port ($ifile arg))
X (cond ((null port)
X (%warn '|accept: file not open for input| arg)
X (return nil)))))
X (cond ((= (tyipeek port) -1.)
X ($value 'end-of-file)
X (return nil)))
X (flat-value (read port))))
X
X(defun flat-value (x)
X (cond ((atom x) ($value x))
X (t (mapc (function flat-value) x))))
X
X(defun span-chars (x prt)
X (do ch (tyipeek prt) (tyipeek prt) (not (member ch x #'char-equal)) (read-char prt)))
X
X(defun acceptline ("e &rest z)
X (prog ( def arg port)
X (setq port t)
X (setq def z)
X (cond (*accept-file*
X (setq port ($ifile *accept-file*))
X (cond ((null port)
X (%warn '|acceptline: file has been closed|
X *accept-file*)
X (return nil)))))
X (cond ((> (length def) 0)
X (setq arg ($varbind (car def)))
X (cond ((and (symbolp arg) ($ifile arg))
X (setq port ($ifile arg))
X (setq def (cdr def))))))
X (span-chars '(9. 41.) port)
X (cond ((memq (tyipeek port) '(-1. 10.))
X (mapc (function $change) def)
X (return nil)))
X lp1 (flat-value (read port))
X (span-chars '(9. 41.) port)
X (cond ((not (memq (tyipeek port) '(-1. 10.))) (go lp1)))))
X
X(defun substr ("e &rest l)
X (prog (k elm start end)
X (cond ((not (= (length l) 3.))
X (%warn '|substr: wrong number of arguments| l)
X (return nil)))
X (setq elm (get-ce-var-bind (car l)))
X (cond ((null elm)
X (%warn '|first argument to substr must be a ce var|
X l)
X (return nil)))
X (setq start ($varbind (cadr l)))
X (setq start ($litbind start))
X (cond ((not (numberp start))
X (%warn '|second argument to substr must be a number|
X l)
X (return nil)))
X (comment |if a variable is bound to INF, the following|
X |will get the binding and treat it as INF is|
X |always treated. that may not be good|)
X (setq end ($varbind (caddr l)))
X (cond ((eq end 'inf) (setq end (length elm))))
X (setq end ($litbind end))
X (cond ((not (numberp end))
X (%warn '|third argument to substr must be a number|
X l)
X (return nil)))
X (comment |this loop does not check for the end of elm|
X |instead it relies on cdr of nil being nil|
X |this may not work in all versions of lisp|)
X (setq k 1.)
X la (cond ((> k end) (return nil))
X ((not (< k start)) ($value (car elm))))
X (setq elm (cdr elm))
X (setq k (1+ k))
X (go la)))
X
X
X(defun compute ("e &rest z) ($value (ari z)))
X
X; arith is the obsolete form of compute
X(defun arith ("e &rest z) ($value (ari z)))
X
X(defun ari (x)
X (cond ((atom x)
X (%warn '|bad syntax in arithmetic expression | x)
X 0.)
X ((atom (cdr x)) (ari-unit (car x)))
X ((eq (cadr x) '+)
X (plus (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '-)
X (difference (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '*)
X (times (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '//)
X (quotient (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '\\)
X (mod (fix (ari-unit (car x))) (fix (ari (cddr x)))))
X (t (%warn '|bad syntax in arithmetic expression | x) 0.)))
X
X(defun ari-unit (a)
X (prog (r)
X (cond ((listp a) (setq r (ari a)))
X (t (setq r ($varbind a))))
X (cond ((not (numberp r))
X (%warn '|bad value in arithmetic expression| a)
X (return 0.))
X (t (return r)))))
X
X(defun genatom nil ($value (gensym)))
X
X(defun litval ("e &rest z)
X (prog (r)
X (cond ((not (= (length z) 1.))
X (%warn '|litval: wrong number of arguments| z)
X ($value 0)
X (return nil))
X ((numberp (car z)) ($value (car z)) (return nil)))
X (setq r ($litbind ($varbind (car z))))
X (cond ((numberp r) ($value r) (return nil)))
X (%warn '|litval: argument has no literal binding| (car z))
X ($value 0)))
X
X
X(defun rjust ("e &rest z)
X (prog (val)
X (cond ((not (= (length z) 1.))
X (%warn '|rjust: wrong number of arguments| z)
X (return nil)))
X (setq val ($varbind (car z)))
X (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
X (%warn '|rjust: illegal value for field width| val)
X (return nil)))
X ($value '|=== R J U S T ===|)
X ($value val)))
X
X(defun crlf ("e &optional z)
X (cond (z (%warn '|crlf: does not take arguments| z))
X (t ($value '|=== C R L F ===|))))
X
X(defun tabto ("e &rest z)
X (prog (val)
X (cond ((not (= (length z) 1.))
X (%warn '|tabto: wrong number of arguments| z)
X (return nil)))
X (setq val ($varbind (car z)))
X (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
X (%warn '|tabto: illegal column number| z)
X (return nil)))
X ($value '|=== T A B T O ===|)
X ($value val)))
X
X
X
X;;; Printing WM
X
X(defun ppwm ("e &rest avlist)
X (prog (next a)
X (setq *filters* nil)
X (setq next 1.)
X l (and (atom avlist) (go print))
X (setq a (car avlist))
X (setq avlist (cdr avlist))
X (cond ((eq a #\^)
X (setq next (car avlist))
X (setq avlist (cdr avlist))
X (setq next ($litbind next))
X (and (floatp next) (setq next (fix next)))
X (cond ((or (not (numberp next))
X (> next *size-result-array*)
X (> 1. next))
X (%warn '|illegal index after ^| next)
X (return nil))))
X ((variablep a)
X (%warn '|ppwm does not take variables| a)
X (return nil))
X (t (setq *filters* (cons next (cons a *filters*)))
X (setq next (1+ next))))
X (go l)
X print (mapwm (function ppwm2))
X (terpri)
X (return nil)))
X
X(defun ppwm2 (elm-tag)
X (cond ((filter (car elm-tag)) (terpri) (ppelm (car elm-tag) t))))
X
X(defun filter (elm)
X (prog (fl indx val)
X (setq fl *filters*)
X top (and (atom fl) (return t))
X (setq indx (car fl))
X (setq val (cadr fl))
X (setq fl (cddr fl))
X (and (ident (nth (1- indx) elm) val) (go top))
X (return nil)))
X
X(defun ident (x y)
X (cond ((eq x y) t)
X ((not (numberp x)) nil)
X ((not (numberp y)) nil)
X ((=alg x y) t)
X (t nil)))
X
X; the new ppelm is designed especially to handle literalize format
X; however, it will do as well as the old ppelm on other formats
X
X(defun ppelm (elm port)
X (prog (ppdat sep val att mode lastpos)
X (princ (creation-time elm) port)
X (princ '|: | port)
X (setq mode 'vector)
X (setq ppdat (get (car elm) 'ppdat))
X (and ppdat (setq mode 'a-v))
X (setq sep '|(|)
X (setq lastpos 0)
X (do
X ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
X ((atom vlist) nil)
X (setq val (car vlist))
X (setq att (assoc curpos ppdat))
X (cond (att (setq att (cdr att)))
X (t (setq att curpos)))
X (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
X (cond ((or (not (null val)) (eq mode 'vector))
X (princ sep port)
X (ppval val att lastpos port)
X (setq sep '| |)
X (setq lastpos curpos))))
X (princ '|)| port)))
X
X(defun ppval (val att lastpos port)
X (cond ((not (equal att (1+ lastpos)))
X (princ '^ port)
X (princ att port)
X (princ '| | port)))
X (princ val port))
X
X
X
X;;; printing production memory
X
X(defmacro pm (&rest z) `(progn (mapc #'pprule ',z) (terpri) nil))
X
X(defun pprule (name)
X (prog (matrix next lab)
X (and (not (symbolp name)) (return nil))
X (setq matrix (get name 'production))
X (and (null matrix) (return nil))
X (terpri)
X (princ '|(p |)
X (princ name)
X top (and (atom matrix) (go fin))
X (setq next (car matrix))
X (setq matrix (cdr matrix))
X (setq lab nil)
X (terpri)
X (cond ((eq next '-)
X (princ '| - |)
X (setq next (car matrix))
X (setq matrix (cdr matrix)))
X ((eq next '-->)
X (princ '| |))
X ((and (eq next '{) (atom (car matrix)))
X (princ '| {|)
X (setq lab (car matrix))
X (setq next (cadr matrix))
X (setq matrix (cdddr matrix)))
X ((eq next '{)
X (princ '| {|)
X (setq lab (cadr matrix))
X (setq next (car matrix))
X (setq matrix (cdddr matrix)))
X (t (princ '| |)))
X (ppline next)
X (cond (lab (princ '| |) (princ lab) (princ '})))
X (go top)
X fin (princ '|)|)))
X
X(defun ppline (line)
X (prog ()
X (cond ((atom line) (princ line))
X (t
X (princ '|(|)
X (setq *ppline* line)
X (ppline2)
X (princ '|)|)))
X (return nil)))
X
X(defun ppline2 ()
X (prog (needspace)
X (setq needspace nil)
X top (and (atom *ppline*) (return nil))
X (and needspace (princ '| |))
X (cond ((eq (car *ppline*) #\^) (ppattval))
X (t (pponlyval)))
X (setq needspace t)
X (go top)))
X
X;NWRITN, sort of. This is implementation dependant for the TI Explorer.
X(defun nwritn(&optional port)
X (cond ((null port)
X (cdr (cursorpos)))
X (t
X (cursorpos port))))
X
X(defun ppattval ()
X (prog (att val)
X (setq att (cadr *ppline*))
X (setq *ppline* (cddr *ppline*))
X (setq val (getval))
X (cond ((> (+ (nwritn) (flatc att) (flatc val)) 76.)
X (terpri)
X (princ '| |)))
X (princ '^)
X (princ att)
X (mapc (function (lambda (z) (princ '| |) (princ z))) val)))
X
X(defun pponlyval ()
X (prog (val needspace)
X (setq val (getval))
X (setq needspace nil)
X (cond ((> (+ (nwritn) (flatc val)) 76.)
X (setq needspace nil)
X (terpri)
X (princ '| |)))
X top (and (atom val) (return nil))
X (and needspace (princ '| |))
X (setq needspace t)
X (princ (car val))
X (setq val (cdr val))
X (go top)))
X
X(defun getval ()
X (prog (res v1)
X (setq v1 (car *ppline*))
X (setq *ppline* (cdr *ppline*))
X (cond ((memq v1 '(= <> < <= => > <=>))
X (setq res (cons v1 (getval))))
X ((eq v1 '{)
X (setq res (cons v1 (getupto '}))))
X ((eq v1 '<<)
X (setq res (cons v1 (getupto '>>))))
X ((eq v1 '//)
X (setq res (list v1 (car *ppline*)))
X (setq *ppline* (cdr *ppline*)))
X (t (setq res (list v1))))
X (return res)))
X
X(defun getupto (end)
X (prog (v)
X (and (atom *ppline*) (return nil))
X (setq v (car *ppline*))
X (setq *ppline* (cdr *ppline*))
X (cond ((eq v end) (return (list v)))
X (t (return (cons v (getupto end)))))))
X
X
X
X
X
X
X;;; backing up
X
X
X
X(defun record-index-plus (k)
X (setq *record-index* (+ k *record-index*))
X (cond ((< *record-index* 0.)
X (setq *record-index* *max-record-index*))
X ((> *record-index* *max-record-index*)
X (setq *record-index* 0.))))
X
X; the following routine initializes the record. putting nil in the
X; first slot indicates that that the record does not go back further
X; than that. (when the system backs up, it writes nil over the used
X; records so that it will recognize which records it has used. thus
X; the system is set up anyway never to back over a nil.)
X
X(defun initialize-record nil
X (setq *record-index* 0.)
X (setq *recording* nil)
X (setq *max-record-index* 31.)
X (putvector *record-array* 0. nil))
X
X; *max-record-index* holds the maximum legal index for record-array
X; so it and the following must be changed at the same time
X
X(defun begin-record (p data)
X (setq *recording* t)
X (setq *record* (list '=>refract p data)))
X
X(defun end-record nil
X (cond (*recording*
X (setq *record*
X (cons *cycle-count* (cons *p-name* *record*)))
X (record-index-plus 1.)
X (putvector *record-array* *record-index* *record*)
X (setq *record* nil)
X (setq *recording* nil))))
X
X(defun record-change (direct time elm)
X (cond (*recording*
X (setq *record*
X (cons direct (cons time (cons elm *record*)))))))
X
X; to maintain refraction information, need keep only one piece of information:
X; need to record all unsuccessful attempts to delete things from the conflict
X; set. unsuccessful deletes are caused by attempting to delete refracted
X; instantiations. when backing up, have to avoid putting things back into the
X; conflict set if they were not deleted when running forward
X
X(defun record-refract (rule data)
X (and *recording*
X (setq *record* (cons '<=refract (cons rule (cons data *record*))))))
X
X(defun refracted (rule data)
X (prog (z)
X (and (null *refracts*) (return nil))
X (setq z (cons rule data))
X (return (member z *refracts*))))
X
X(defun back (k)
X (prog (r)
X l (and (< k 1.) (return nil))
X (setq r (getvector *record-array* *record-index*))
X (and (null r) (return '|nothing more stored|))
X (putvector *record-array* *record-index* nil)
X (record-index-plus -1.)
X (undo-record r)
X (setq k (1- k))
X (go l)))
X
X(defun undo-record (r)
X (prog (save act a b rate)
X (comment *recording* must be off during back up)
X (setq save *recording*)
X (setq *refracts* nil)
X (setq *recording* nil)
X (and *ptrace* (back-print (list 'undo (car r) (cadr r))))
X (setq r (cddr r))
X top (and (atom r) (go fin))
X (setq act (car r))
X (setq a (cadr r))
X (setq b (caddr r))
X (setq r (cdddr r))
X (and *wtrace* (back-print (list 'undo act a)))
X (cond ((eq act '<=wm) (add-to-wm b a))
X ((eq act '=>wm) (remove-from-wm b))
X ((eq act '<=refract)
X (setq *refracts* (cons (cons a b) *refracts*)))
X ((and (eq act '=>refract) (still-present b))
X (setq *refracts* (delete (cons a b) *refracts*))
X (setq rate (rating-part (get a 'topnode)))
X (removecs a b)
X (insertcs a b rate))
X (t (%warn '|back: cannot undo action| (list act a))))
X (go top)
X fin (setq *recording* save)
X (setq *refracts* nil)
X (return nil)))
X
X; still-present makes sure that the user has not deleted something
X; from wm which occurs in the instantiation about to be restored; it
X; makes the check by determining whether each wme still has a time tag.
X
X(defun still-present (data)
X (prog nil
X l (cond ((atom data) (return t))
X ((creation-time (car data))
X (setq data (cdr data))
X (go l))
X (t (return nil)))))
X
X
X(defun back-print (x)
X (prog (port)
X (setq port (trace-file))
X (terpri port)
X (print x port)))
X
X
X
X
X;;; Functions to show how close rules are to firing
X
X(defun matches ("e &rest rule-list)
X (progn
X (mapc (function matches2) rule-list)
X (terpri)) )
X
X(defun matches2 (p)
X (cond ((atom p)
X (terpri)
X (terpri)
X (princ p)
X (matches3 (get p 'backpointers) 2. (ncons 1.)))))
X
X(defun matches3 (nodes ce part)
X (cond ((not (null nodes))
X (terpri)
X (princ '| ** matches for |)
X (princ part)
X (princ '| ** |)
X (mapc (function write-elms) (find-left-mem (car nodes)))
X (terpri)
X (princ '| ** matches for |)
X (princ (ncons ce))
X (princ '| ** |)
X (mapc (function write-elms) (find-right-mem (car nodes)))
X (matches3 (cdr nodes) (1+ ce) (cons ce part)))))
X
X(defun write-elms (wme-or-count)
X (cond ((listp wme-or-count)
X (terpri)
X (mapc (function write-elms2) wme-or-count))))
X
X(defun write-elms2 (x)
X (princ '| |)
X (princ (creation-time x)))
X
X(defun find-left-mem (node)
X (cond ((eq (car node) '&and) (memory-part (caddr node)))
X (t (car (caddr node)))))
X
X(defun find-right-mem (node) (memory-part (cadddr node)))
X
X
X;;; Check the RHSs of productions
X
X
X(defun check-rhs (rhs) (mapc (function check-action) rhs))
X
X(defun check-action (x)
X (prog (a)
X (cond ((atom x)
X (%warn '|atomic action| x)
X (return nil)))
X (setq a (car x))
X (cond ((eq a 'bind) (check-bind x))
X ((eq a 'cbind) (check-cbind x))
X ((eq a 'make) (check-make x))
X ((eq a 'modify) (check-modify x))
X ((eq a 'oremove) (check-remove x))
X ((eq a 'owrite) (check-write x))
X ((eq a 'ocall) (check-call x))
X ((eq a 'halt) (check-halt x))
X ((eq a 'openfile) (check-openfile x))
X ((eq a 'closefile) (check-closefile x))
X ((eq a 'default) (check-default x))
X ((eq a 'build) (check-build x))
X ;;the following section is responsible for replacing standard ops RHS actions
X ;;with actions which don't conflict with existing CL functions. The RPLACA function
X ;;is used so that the change will be reflected in the production body.
X ((eq a 'remove) (rplaca x 'oremove)
X (check-remove x))
X ((eq a 'write) (rplaca x 'owrite)
X (check-write x))
X ((eq a 'call) (rplaca x 'ocall)
X (check-call x))
X (t (%warn '|undefined rhs action| a)))))
X
X(defun check-build (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-build-collect (cdr z)))
X
X(defun check-build-collect (args)
X (prog (r)
X top (and (null args) (return nil))
X (setq r (car args))
X (setq args (cdr args))
X (cond ((listp r) (check-build-collect r))
X ((eq r '\\)
X (and (null args) (%warn '|nothing to evaluate| r))
X (check-rhs-value (car args))
X (setq args (cdr args))))
X (go top)))
X
X(defun check-remove (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (mapc (function check-rhs-ce-var) (cdr z)))
X
X(defun check-make (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-openfile (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-closefile (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-default (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-modify (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-rhs-ce-var (cadr z))
X (and (null (cddr z)) (%warn '|no changes to make| z))
X (check-change& (cddr z)))
X
X(defun check-write (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-call (z)
X (prog (f)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (setq f (cadr z))
X (and (variablep f)
X (%warn '|function name must be a constant| z))
X (or (symbolp f)
X (%warn '|function name must be a symbolic atom| f))
X (or (externalp f)
X (%warn '|function name not declared external| f))
X (check-change& (cddr z))))
X
X(defun check-halt (z)
X (or (null (cdr z)) (%warn '|does not take arguments| z)))
X
X(defun check-cbind (z)
X (prog (v)
X (or (= (length z) 2.) (%warn '|takes only one argument| z))
X (setq v (cadr z))
X (or (variablep v) (%warn '|takes variable as argument| z))
X (note-ce-variable v)))
X
X(defun check-bind (z)
X (prog (v)
X (or (> (length z) 1.) (%warn '|needs arguments| z))
X (setq v (cadr z))
X (or (variablep v) (%warn '|takes variable as argument| z))
X (note-variable v)
X (check-change& (cddr z))))
X
X
X(defun check-change& (z)
X (prog (r tab-flag)
X (setq tab-flag nil)
X la (and (atom z) (return nil))
X (setq r (car z))
X (setq z (cdr z))
X (cond ((eq r #\^)
X (and tab-flag
X (%warn '|no value before this tab| (car z)))
X (setq tab-flag t)
X (check-tab-index (car z))
X (setq z (cdr z)))
X ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
X (t (setq tab-flag nil) (check-rhs-value r)))
X (go la)))
X
X(defun check-rhs-ce-var (v)
X (cond ((and (not (numberp v)) (not (ce-bound? v)))
X (%warn '|unbound element variable| v))
X ((and (numberp v) (or (< v 1.) (> v *ce-count*)))
X (%warn '|numeric element designator out of bounds| v))))
X
X(defun check-rhs-value (x)
X (cond ((and x (listp x)) (check-rhs-function x))
X (t (check-rhs-atomic x))))
X
X(defun check-rhs-atomic (x)
X (and (variablep x)
X (not (bound? x))
X (%warn '|unbound variable| x)))
X
X(defun check-rhs-function (x)
X (prog (a)
X (setq a (car x))
X (cond ((eq a 'compute) (check-compute x))
--
---------------
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-9400turner@imagen.UUCP (D'arc Angel) (01/19/87)
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 <p1> ^to <p2>) <exp0> }
X -->
X (remove <exp0>)
X (make time-to-act) ; start act/move cycle
X (make on ^peg <p1>) ; set the starting point
X (make end ^is <p2>)) ; 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 <p>) ; on a peg
X (end ^is <p>) ; which is the end peg
X (follows ^peg1 <p> ^peg2 <p1>) ; which follows peg p1
X (follows ^peg1 <p2> ^peg2 <p>) ; is followed by peg p2
X -(top ^disk <d> ^peg <p1>) ; both other pegs
X -(top ^disk <e> ^peg <p2>) ; 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) <exp0> }
X-->
X (remove <exp0>)
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 <p>) ; current peg
X { (top ^disk <d> ^peg <p>) <exp0> } ; find the top disk
X { (under ^disk1 <e> ^disk2 <d>) <exp1> } ; is there one under it?
X { (time-to-act) <exp2> } ; is it time-to-act?
X { (peg ^name <p> ^disks <d> <e> <f>) <exp3> } ; get peg stack
X -(holding ^disk <x>) ; not already holding a disk?
X-->
X (make top ^disk <e> ^peg <p>) ; reset top disk
X (remove <exp0> <exp1> <exp2> <exp3>)
X (make holding ^disk <d>) ; now holding disk
X (make peg ^name <p> ^disks 0 <e> <f>) ; 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 <p>) ; current peg
X { (top ^disk <d> ^peg <p>) <exp0> } ; find top disk
X { (under ^disk1 <e> ^disk2 <d>) <exp1> } ; something under the top
X { (time-to-act) <exp2> } ; time-to-act?
X { (peg ^name <p> ^disks 0 <d> <e>) <exp3> } ; get part full peg stack
X -(holding ^disk <x>) ; not holding a disk already?
X-->
X (remove <exp0> <exp1> <exp2> <exp3>)
X (make top ^disk <e> ^peg <p>) ; reset top disk
X (make peg ^name <p> ^disks 0 0 <e>) ; reset peg stack
X (make holding ^disk <d>) ; 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 <p>) ; as above...
X { (top ^disk <d> ^peg <p>) <exp0> } ; except for peg stack with
X { (time-to-act) <exp1> } ; with only one disk
X { (peg ^name <p> ^disks 0 0 <d>) <exp2> }
X -(under ^disk1 <d> ^disk2 <e>)
X -(holding ^disk <x>)
X-->
X (remove <exp0> <exp1> <exp2>)
X (make holding ^disk <d>)
X (make peg ^name <p> ^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 <p>) <exp0> }
X (follows ^peg1 <next> ^peg2 <p>)
X { (time-to-move) <exp1> }
X-->
X (remove <exp0> <exp1>)
X (make on ^peg <next>)
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 <d>) <exp0> }
X (on ^peg <p>)
X { (top ^disk <top> ^peg <p>) <exp1> }
X (smaller ^disk1 <d> ^disk2 <top>)
X { (time-to-act) <exp2> }
X { (peg ^name <p> ^disks 0 <top> <bot>) <exp3> }
X-->
X (remove <exp0> <exp1> <exp2> <exp3>)
X (make top ^disk <d> ^peg <p>)
X (make under ^disk1 <top> ^disk2 <d>)
X (make peg ^name <p> ^disks <d> <top> <bot>)
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 <d>) <exp0> }
X (on ^peg <p>)
X { (top ^disk <top> ^peg <p>) <exp1> }
X (smaller ^disk1 <d> ^disk2 <top>)
X { (time-to-act) <exp2> }
X { (peg ^name <p> ^disks 0 0 <top>) <exp3> }
X-->
X (remove <exp0> <exp1> <exp2> <exp3>)
X (make top ^disk <d> ^peg <p>)
X (make under ^disk1 <top> ^disk2 <d>)
X (make peg ^name <p> ^disks 0 <d> <top>)
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 <d>) <exp0> }
X (on ^peg <p>)
X { (time-to-act) <exp1> }
X -(top ^disk <e> ^peg <p>)
X { (peg ^name <p> ^disks 0 0 0) <exp2> }
X-->
X (remove <exp0> <exp1> <exp2>)
X (make peg ^name <p> ^disks 0 0 <d>)
X (make top ^disk <d> ^peg <p>)
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) <exp0> }
X (peg ^name a ^disks <d1> <d4> <d7>)
X (peg ^name b ^disks <d2> <d5> <d8>)
X (peg ^name c ^disks <d3> <d6> <d9>)
X (peg ^name base ^disks <b1> <b2> <b3>)
X-->
X (call print-towers <d1> <d2> <d3> <d4> <d5> <d6> <d7> <d8> <d9> <b1> <b2> <b3>)
X (remove <exp0>)
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 MEMBER<NONMEMBER THEN 580
X577 PRINT"One":GOTO 590
X580 PRINT"Two"
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$="N" THEN 670
X630 K=0:KK=0:KZ=0:FOR I=1 TO LOOPSCAN*SIZE*SIZE
X640 FOR J=0 TO 1
X650 A=NEURALNET(I,J):IF A=1 THEN ?"*"; ELSE ?".";
X660 K=K+1:IF K>SIZE 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 MEMBER<NONMEMBER THEN 580
X577 PRINT"Two.";:GOTO 588
X580 PRINT"One.";
X588 IF ABS(MEMBER-NONMEMBER)>1 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