TO REMOVE :OLD.ITEM :LIST
IF EMPTY? :LIST [OP []] 
IF :OLD.ITEM = FIRST :LIST [OP BF :LIST] 
OP FPUT FIRST :LIST REMOVE :OLD.ITEM BF :LIST 
END

TO START
D 
NOB 
IF NOT MEMBER? `GRAMMAR ONE` WINDOWS 	
 [MAKEWINDOW "TEXT `GRAMMAR ONE`] 
SETWWRAP `GRAMMAR ONE` "TRUE 
SETWPOS `GRAMMAR ONE` [0 40] 
SETWSIZE `GRAMMAR ONE` [514 300] 
SETACTIVEW `GRAMMAR ONE` 
CLEARTEXT 
SETWWRAP `GRAMMAR ONE` "TRUE 
PR [] PR [] PR [] 
PR [AVAILABLE PROCEDURES ARE: -] 
PR [] PR [] 
PR [HELP] 
PR [START] 
PR [WRITE.RULES] 
PR [RUN.RULES] 
PR [LIST.RULES] 
PR [KILL] 
PR [SRP ( SHIFT - REDUCE PARSER )] 
PR [STORE ( SAVE RULES )] 
PR [LOAD ( LOAD RULES )] 
PR [D\(ERIVATION\)] 
PR [NOD\(ERIVATION\)] 
PR [B\(RACKETS\)] 
PR [NOB\(RACKETS\)] 
PR [CLEAROUT] 
PR [BYE] 
PR [] PR [] PR [] 
END

TO SUBSTITUTE :CONSTITUENT :EXPANSION :LIST
IF EMPTY? :LIST [OP []] 
IF AND :BRACKETS :CONSTITUENT = FIRST :LIST [OP ( SE "\( :EXPANSION "\) BF :LIST )] 
IF :CONSTITUENT = FIRST :LIST [OP SE :EXPANSION BF :LIST] 
OP FPUT FIRST :LIST SUBSTITUTE :CONSTITUENT :EXPANSION BF :LIST 
END

TO B
BRACKETS 
END

TO NOD
NODERIVATION 
END

TO D
DERIVATION 
END

TO PUT.IN.RULES :NEW.RULE
LOCAL "OLD.VERSION 
MAKE "OLD.VERSION ASSOC FIRST :NEW.RULE :RULES 
IF :OLD.VERSION = :NEW.RULE [PR [] PR [RULE EXISTS!] PR [] STOP] 
IF EMPTY? :OLD.VERSION 	
   [MAKE "RULES LPUT :NEW.RULE :RULES] 	
   [MAKE "RULES REPLACE :OLD.VERSION LPUT LAST :NEW.RULE :OLD.VERSION :RULES] 
END

TO HELP.LIST
CLEARTEXT 
PR [LIST.RULES] PR [] PR [] 
PR [THE COMPLETE RULE SYSTEM CAN BE CHECKED BY TYPING: LIST.RULES] 
PR [] 
END

TO HELP.RUN
CLEARTEXT 
PR [] 
PR [TO RUN THE RULES WHICH EXPAND CONSTITUENT X, TYPE: -] 
PR [] PR [RUN.RULES [X]] 
PR [] 
PR [EXX:] 
PR [RUN.RULES [NP]] 
PR [RUN.RULES [POEM]] 
PR [] 
PR [INSTEAD OF RUN.RULES [S] YOU CAN JUST TYPE: S] 
PR [] 
END

TO NOB
NOBRACKETS 
END

TO TRYOUT :STACK :RULES
IF EMPTY? :RULES [OP :STACK] 
LOCAL "POSITION MAKE "POSITION 0 
IF MATCH? :STACK BF FIRST :RULES 	
  [MAKE "NEW.ANALYSIS LIST FIRST FIRST :RULES ITEM :POSITION BF FIRST :RULES MAKE "ANALYSIS FPUT :NEW.ANALYSIS :ANALYSIS OP COLLAPSE :STACK :NEW.ANALYSIS] 
OP TRYOUT :STACK BF :RULES 
END

TO FITS? :STACK :EXPANSION
IF AND EMPTY? :STACK EMPTY? :EXPANSION [OP "TRUE] 
IF EMPTY? :EXPANSION [OP "TRUE] 
IF EMPTY? :STACK [OP "FALSE] 
IF ( LAST :STACK ) = ( LAST :EXPANSION ) [OP FITS? BL :STACK BL :EXPANSION] 
OP "FALSE 
END

TO HELP.STORE
CLEARTEXT 
PR [] PR [] 
PR [SAVING RULES] 
PR [] 
PR [THE COMMAND 'STORE' ALLOWS YOU TO SAVE THE GRAMMAR RULES YOU HAVE WRITTEN] 
PR [AS A SEPARATE FILE ON DISC.] 
PR [] 
PR [TO USE THE COMMAND TYPE:] 
PR [STORE "FILENAME] 
PR [] 
PR [EG. STORE "ENGLISH1] 
PR [] 
PR [YOU WILL NOTICE WHEN LOOKING FOR FILES SAVED IN THIS WAY THAT THE FILENAMES] 
PR [HAVE BEEN AUTOMATICALLY EXTENDED WITH A SUFFIX '.RLS' TO HELP IDENTIFY THEM.] 
PR [] 
PR [DO NOT USE SPACES IN THE FILENAME!] 
END

TO SWOP :STACK.STRING :CATEGORY :EXPANSION
IF EMPTY? :EXPANSION [OP ( LIST :CATEGORY )] 
IF ( COUNT :STACK.STRING ) = ( COUNT :EXPANSION ) [OP ( LIST :CATEGORY )] 
OP FPUT FIRST :STACK.STRING SWOP BF :STACK.STRING :CATEGORY :EXPANSION 
END

TO WRITE.RULES
IF NOT MEMBER? `WRITE.RULES` WINDOWS 	
[MAKEWINDOW "TEXT `WRITE.RULES`] 
SETWPOS "WRITE.RULES [15 40] 
SETWSIZE "WRITE.RULES [450 280] 
SETACTIVEW "WRITE.RULES 
CLEARTEXT 
WRITE 
START 
END

TO RUN.RULES :CURRENT.STRING
DO.RULES :CURRENT.STRING 
IF NOT TRACE.ON? [PR :CURRENT.STRING] 
END

TO SHIFT :STRING
MAKE "STACK LPUT FIRST :STRING :STACK 
END

TO STORE :FILENAME
BURYALL 
UNBURYNAME "RULES 
SAVE WORD :FILENAME ".RLS 
UNBURYALL 
END

TO CLEAR.OUT
MAKE "RULES [] 
END

TO KILL :X
MAKE "RULES REMOVE ( ASSOC :X :RULES ) :RULES 
END

TO HELP.WRITE
CLEARTEXT 
PR [] PR [] 
PR [WHEN WRITING RULES USE THE FORMAT: -] 
PR [] 
PR [CONSTITUENT [EXPANSION]] 
PR [] 
PR [EXX.] 
PR [S [NP VP]] 
PR [N [CAT]] 
PR [] 
PR [WRITE ALTERNATIVE EXPANSIONS AS SEPARATE RULES] 
PR [] 
PR [LEAVE WRITE RULES BY TYPING: STOP] 
PR [] 
END

TO HELP.SWITCH
CLEARTEXT 
PR [] 
PR [A TRACE OF THE DERIVATION IS PROVIDED] 
PR [] 
PR [TO SWITCH TRACING ON OR OFF JUST TYPE: SWITCH.TRACE] 
PR [] 
END

TO NOBRACKETS
MAKE "BRACKETS "FALSE 
END

TO WRITE
LOCAL "LINE 
PR [RULE: -] 
MAKE "LINE RL 
IF ( FIRST :LINE ) = "STOP [STOP] 
IF EMPTY? BF :LINE [PR [ERROR! TRY AGAIN] GO "AGAIN] 
PUT.IN.RULES :LINE 
AGAIN: WRITE 
END

TO LIST.RULES
CLEARTEXT 
PR [] 
SPELL.OUT :RULES 
PR [] 
END

TO REDUCE.STACK
MAKE "OLDSTACK :STACK 
MAKE "STACK TRYOUT :STACK :RULES 
IF :OLDSTACK = :STACK [STOP] 
PR :STACK 
REDUCE.STACK 
END

TO NODERIVATION
MAKE "TRACE "FALSE 
END

TO VPRINT :LIST
IF EMPTY? :LIST [STOP] 
PR FIRST :LIST 
VPRINT BF :LIST 
END

TO S.R.PARSE :STRING
IF AND :STACK = [S] EMPTY? :STRING [PR [] PR [SUCCESSFULLY PARSED!] PR [] STOP] 
IF EMPTY? :STRING [PR [] PR [PARSE FAILED!] PR [] STOP] 
SHIFT :STRING 
REDUCE.STACK 
S.R.PARSE BF :STRING 
END

TO HELP.SRP
CLEARTEXT 
PR [] PR [] 
PR [A SHIFT REDUCE PARSER] 
PR [] 
PR [THE COMMAND SRP RUNS A SIMPLE SHIFT REDUCE PARSER.] 
PR [THE WORDS OF THE SENTENCE TO BE ANALYSED ARE LOADED - ONE BY ONE FROM] 
PR [THE LEFT - ONTO A STACK.] 
PR [AT EACH STEP THE STACK IS EXAMINED FROM THE TOP DOWN] 
PR [TO SEE IF ITS CONTENTS - OR SOME LAST PART OF ITS CONTENTS -] 
PR [CAN BE REPLACED BY ( OR REDUCED TO ) SOME CATEGORY BY USING THE] 
PR [GRAMMAR RULES IN THE SYSTEM.] 
PR [IF, WHEN THE WHOLE SENTENCE HAS BEEN PROCESSED, THE STACK CONTAINS ONLY] 
PR [THE CATEGORY 'S', A SUCCESSFUL PARSE HAS BEEN ACHIEVED.] 
PR [THE CHANGING STACK CONTENTS AND THE RULES USED ARE DISPLAYED.] 
PR [] 
PR [NOTE THAT ALL WORDS OF THE INPUT SENTENCE MUST BE KNOWN TO THE RULES.] 
PR [NOTE ALSO THAT GRAMMAR RULES OF A CERTAIN TYPE WILL MAKE THIS PARSER FAIL.] 
PR [WHICH TYPE?] 
PR [] 
PR [TO USE THE COMMAND, TYPE SRP FOLLOWED BY A SENTENCE IN SQUARE BRACKETS] 
PR [] 
PR [EG. SRP [THE DOG BITES THE CAT]] 
PR [] 
END

TO REWRITE :CONSTITUENT :EXPANSION
;rewrites all occurences of constituent in current.string
LOCAL "NEW.STRING 
MAKE "NEW.STRING SUBSTITUTE :CONSTITUENT ( PICKRANDOM :EXPANSION ) :CURRENT.STRING 
IF :CURRENT.STRING = :NEW.STRING [STOP] 
MAKE "CURRENT.STRING :NEW.STRING 
IF TRACE.ON? [PR :CURRENT.STRING] 
REWRITE :CONSTITUENT :EXPANSION 
END

TO DO.RULES :INPUT.STRING
APPLY :RULES 
IF :CURRENT.STRING = :INPUT.STRING [STOP] [DO.RULES :CURRENT.STRING] 
END

TO S
RUN.RULES [S] 
END

TO PICKRANDOM :LIST
OP ITEM ( 1 + RANDOM COUNT :LIST ) :LIST 
END

TO CLEARDECKS
CLEARTEXT 
MAKE "STACK [] 
MAKE "ANALYSIS [] 
END

TO SPELL.OUT :RULE.LIST
IF EMPTY? :RULE.LIST [STOP] 
PR ( SE FIRST FIRST :RULE.LIST [->] BF FIRST :RULE.LIST ) 
SPELL.OUT BF :RULE.LIST 
END

TO APPLY :RULE.SYSTEM
;works through each rule in the rule.system and applies the rule if the left-hand side is a member of the current.string
IF EMPTY? :RULE.SYSTEM [STOP] 
MAKE "CURRENT.RULE FIRST :RULE.SYSTEM 
IF MEMBER? FIRST :CURRENT.RULE :CURRENT.STRING [REWRITE FIRST :CURRENT.RULE BF :CURRENT.RULE] 
APPLY BF :RULE.SYSTEM 
END

TO COLLAPSE :STACK :RULE
OP SWOP :STACK FIRST :RULE LAST :RULE 
END

TO SRP :STRING
CLEARDECKS 
PR [INPUT SENTENCE:] 
PR :STRING PR [] 
PR [STACK CONTENTS] PR [] 
S.R.PARSE :STRING 
PR [RULES USED] PR [] 
VPRINT :ANALYSIS 
END

TO HELP.KILL
CLEARTEXT 
PR [] PR [] 
PR [TO REMOVE ALL EXPANSIONS OF SOME CATEGORY: -] 
PR [] 
PR [TYPE KILL "CATEGORY.NAME] 
PR [] 
PR [EXX.] 
PR [KILL "NP] 
PR [KILL "DET] 
PR [] 
PR [LOADING A NEW SET OF GRAMMAR RULES WILL KILL THE EXISTING SET.] 
PR [YOU CAN ALSO REMOVE THE EXISTING SET OF RULES BY TYPING: CLEAROUT] 
END

TO BRACKETS
MAKE "BRACKETS "TRUE 
END

TO MATCH? :CATEGORY.STRING :EXPANSIONS
IF EMPTY? :EXPANSIONS [OP "FALSE] 
MAKE "POSITION :POSITION + 1 
IF FITS? :CATEGORY.STRING FIRST :EXPANSIONS [OP "TRUE] 
OP MATCH? :CATEGORY.STRING BF :EXPANSIONS 
END

TO REPLACE :OLD.ITEM :NEW.ITEM :LIST
IF EMPTY? :LIST [OP []] 
IF :OLD.ITEM = FIRST :LIST [OP FPUT :NEW.ITEM BF :LIST] 
OP FPUT FIRST :LIST REPLACE :OLD.ITEM :NEW.ITEM BF :LIST 
END

TO ASSOC :KEY :A.LIST
IF EMPTY? :A.LIST [OP []] 
IF :KEY = FIRST FIRST :A.LIST [OP FIRST :A.LIST] [OP ASSOC :KEY BF :A.LIST] 
END

TO TRACE.ON?
OP :TRACE 
END

TO BYE
CLOSE WINDOWS 
OPEN "TEXT "#TEXT 
SETWPOS "TEXT [15 40] 
SETWSIZE "TEXT [450 280] 
SETWRITE "TEXT 
END

TO DERIVATION
MAKE "TRACE "TRUE 
END

TO CLEAROUT
MAKE "RULES [] 
PR [] 
PR [O.K. ALL GRAMMAR RULES ERASED.] 
PR [] 
END

TO HELP
IF NOT MEMBER? `GRAMMAR HELP` WINDOWS [MAKEWINDOW "TEXT `GRAMMAR HELP`] 
SETWPOS `GRAMMAR HELP` [5 40] 
SETWSIZE `GRAMMAR HELP` [485 280] 
SETACTIVEW `GRAMMAR HELP` 
CLEARTEXT 
PR [] PR [] PR [] 
PR [HELP IS AVAILABLE FOR A NUMBER OF COMMANDS] 
PR [] 
PR [TYPE ANY OF THE FOLLOWING:] 
PR [] 
PR [HELP.WRITE] 
PR [HELP.RUN] 
PR [HELP.SRP] 
PR [HELP.STORE] 
PR [HELP.KILL] 
PR [] 
PR [USE LOAD FROM THE FILE MENU TO LOAD UP ANY GRAMMAR RULES YOU HAVE SAVED.] 
END

MAKE "OLDSTACK [S]
MAKE "RULES [[NP [DET N] [DET ADJ N] [PROPN] [ADJ PROPN]] [VP [VI] [VT NP] [VS DEP.S] [VDT NP LOC]] [VS [HOPES] [DOUBTS] [DENIES]] [VT [LIKES] [HATES] [BITES]] [VI [SMOKES] [SLEEPS] [FIGHTS]] [N [DOG] [CAT] [PIG] [GOAT] [HORSE] [CHIPMUNK]] [DET [THE] [MY] [A]] [ADJ [VERY ADJ] [STUPID] [BIG] [HAIRY]] [PROPN [JOHN] [MARY]] [ADV [ON TUESDAYS] [TODAY] [SOMETIMES]] [COMP [THAT]] [DEP.S [COMP S]] [S [NP VP] [ADV S]] [EDIT "WRITE.RULES] [VDT [PUT]] [LOC [ON NP] [UNDER NP]]]
MAKE "TRACE "TRUE
MAKE "ANALYSIS [[S [NP VP]] [VP [VT NP]] [NP [DET N]] [N [CAT]] [DET [THE]] [VT [BITES]] [NP [DET N]] [N [DOG]] [DET [THE]]]
MAKE "CURRENT.RULE [LOC [ON NP] [UNDER NP]]
MAKE "BRACKETS "FALSE
MAKE "NEW.ANALYSIS [S [NP VP]]
MAKE "STACK [S]
ÿ