(*
 * LANGUAGE    : ANS Forth 
 * PROJECT     : Forth Environments
 * DESCRIPTION : neural net with backpropagation
 * CATEGORY    : Example
 * AUTHOR      : Marcel Hendrix, November 26 1989
 * LAST CHANGE : October 13, 1991, Marcel Hendrix 
 *)



	   ?DEF Sensors [IF] FORGET Sensors
		      [THEN]



-- ****	Define the layers. ******************************************


6 =: Sensors		-- Inputs
2 =: HiddenUnits	-- set up 1-dimensional I/Hidden/O vectors
			-- NOTE that this is ONE unit less than WJ&JH used!
			-- (We have a Hidden HiddenUnit though (dummy)).
7 =: OutputUnits	-- 7 outputs


		     INCLUDE backprop.frt

	 REVISION -lrrh "ÄÄÄ Neural Applications: LRRH   1.11 ÄÄÄ"


-- ****	End of layer defs. ******************************************

			(* Application Level *)

:ABOUT
CR
CR ."	      ** Little Red Riding Hood Learns the Facts of Life II **"
CR ."             A Neural Net Application using Backpropagation      " 
CR
CR ." <l> <s> ADD-PAIR          -- Pattern <l> is primed for linking with <s>."
CR ."                                 <l> î {Grandma Wolf Woodcutter}"
CR ."                                 <s> î {Love Hate Sex}."
CR ." DRILL                     -- All primed pairs are coded-in."
CR ." NO-CONNECTIONS            -- Forget all associations."
CR ." <l> REACT                 -- Test if <l> <s> pair is reproduced."
CR ." .STATUS                   -- Prints inputs | outputs | targets."
CR ." .WEIGHTS                  -- Prints all weights."
CR ." <z> TO LearningRate       -- LearningRate, oscillates if too large (>1000)."
CR ." <w> TO Retries            -- Retry Rate (normally 3000)."
CR ." Noisy | Clean             -- Select if input is noisy or not."
CR ." <y> TO Noise              -- 1 out of <y> relations in <l> is corrupted, if Noisy."
CR ." FALSE | TRUE TO ?display  -- See matrices during learning or not."
CR ." DO-IT!                    -- Sets up defaults and learns the patterns."
CR ." .ABOUT -lrrh              -- Print this info." CR
CR ." Note1: When running,      '+'  and  '-' influence LearningRate,"
CR ."                           '/'  switches between .STATUS and .WEIGHTS,"
CR ."                           'd'  turns display on and off,"
CR ."                           'ESC' breaks." 
CR ." Note2: <list> PERSON WHATIF? "
CR ."        where <list> is ORed members of the following set: "
CR ."          {BigEars BigEyes BigTeeth Kindly Wrinkled Handsome}" 
CR ."        Example: BigEars BigTeeth OR PERSON WHATIF? " ;

	-- Bitpatterns: (by virtue of these definitions, only 16 characteristics
	--		are possible ==> n <= 16)

0 2^x =: BigEars	1 2^x =: BigEyes	2 2^x =: BigTeeth
3 2^x =: Kindly		4 2^x =: Wrinkled	5 2^x =: Handsome

	-- Likewise, number of actions (p) limited to 16.

0 2^x =: RunAway	1 2^x =: Scream		2 2^x =: Look?
3 2^x =: Kiss		4 2^x =: Approach	5 2^x =: OfferFood
6 2^x =: Flirt

CREATE Grandma		0 1 0 1 1 0   sensor,	  -- BigEyes Kindly  Wrinkled
CREATE Wolf		1 1 1 0 0 0   sensor,	  -- BigEars BigEyes BigTeeth
CREATE Woodcutter	1 0 0 1 0 1   sensor,	  -- BigEars Kindly  Handsome

	-- Output patterns

CREATE Love		0 0 0 1 1 1 0 output,	 -- Kiss     Approach  OfferFood
CREATE Hate		1 1 1 0 0 0 0 output,	 -- RunAway  Scream    Look?
CREATE Sex		0 0 0 0 1 1 1 output,	 -- Approach OfferFood Flirt

	-- PERSON only works if n <= 32

Sensors 2+ ARRAY aperson  
		Sensors 1+ TO 0 aperson 
		       One TO 1 aperson

: PERSON	DEPTH 0= ABORT" Describe!"	\ <bp1>..<bpn> --- <'input>
		DEPTH 1- 0 ?DO OR LOOP		\ BigEars PERSON  WHATIF?
		#32 Sensors - LSHIFT
		Sensors 0 DO DUP 0< IF One ELSE Zero ENDIF
			     Sensors 1- I - 2+ TO aperson
		             1 LSHIFT
		        LOOP DROP 
		'OF aperson ;

: .FACT		"0.5"				\ <n> <bool> --- <>
		 > IF CR 1- 2^x
			CASE 
			  BigEars  OF ." -- Big ears"              ENDOF
			  BigEyes  OF ." -- Big eyes"              ENDOF
			  BigTeeth OF ." -- Big teeth"             ENDOF
			  Kindly   OF ." -- A kindly appearance"   ENDOF
			  Wrinkled OF ." -- A wrinkled complexion" ENDOF
			  Handsome OF ." -- A handsome feller"     ENDOF
			  	      ." -- something illegal?"
			ENDCASE
		 ELSE DROP
		ENDIF ;

: .ACTION					\ <n> <bool> --- <>
		"0.5"
		 > IF CR 2^x
			CASE 
			  RunAway   OF ." -- run away"   	      ENDOF
			  Scream    OF ." -- scream"	 	      ENDOF
			  Look?	    OF ." -- look for the woodcutter" ENDOF
			  Kiss	    OF ." -- kiss on the cheek"       ENDOF
			  Approach  OF ." -- approach"	 	      ENDOF
			  OfferFood OF ." -- offer food" 	      ENDOF
			  Flirt	    OF ." -- flirt"	 	      ENDOF
			  	       ." -- it is something illegal?" 
			ENDCASE
		 ELSE DROP
		ENDIF ;

: doLrrh-sensation
		CR ." The little girl digests the following facts :" CR
		/inputs
		    1 DO
			 I I InputValues .FACT
		    LOOP
		CR CR ." That is why she decides to: " CR
		/outputs
		    0 DO
			 I I ActualOutputs .ACTION
		    LOOP CR ;

: Lrrh-sensation ['] doLrrh-sensation IS SHOW-NET ;

: doLrrh	TIMER-RESET
		 NO-CONNECTIONS
		 Grandma Love	ADD-PAIR
		 Wolf Hate	ADD-PAIR
		 Woodcutter Sex ADD-PAIR
		 DRILL
		.ELAPSED ;

: Lrrh		['] doLrrh IS DO-IT! ;

		Lrrh-sensation Lrrh  #900 TO LearningRate 
		.ABOUT -lrrh

			(* End of Application *)