shen-ruby 0.1.0

data/shen/release/test_programs/classes-untyped.shen

@@ -0,0 +1,46 @@
+(define defclass
+   Class Attributes 
+   -> (let Assoc (map (/. Attribute [Attribute | fail]) Attributes)
+           ClassDef [[class | Class] | Assoc]
+           Store (put Class classdef ClassDef)
+           Class))             
+
+(define make-instance
+   Class -> (let ClassDef (trap-error (get Class classdef) (/. E []))
+                 (if (empty? ClassDef)
+                     (error "class ~A does not exist~%" Class)
+                     ClassDef))) 
+
+(define get-value
+   Attribute Instance -> (let LookUp (assoc Attribute Instance)
+                              (get-value-test LookUp)))
+
+(define get-value-test
+  [ ] -> (error "no such attribute!~%")
+  [_ | fail] -> (error "no such value!~%")
+  [_ | Value] -> Value) 
+
+(define has-value?
+  Attribute Instance -> (let LookUp (assoc Attribute Instance)
+                             (has-value-test LookUp)))
+
+(define has-value-test
+  [ ] -> (error "no such attribute!~%")
+  [_ | fail] -> false
+  _ -> true) 
+
+(define has-attribute?
+  Attribute Instance -> (let LookUp (assoc Attribute Instance)
+                             (not (empty? LookUp))))
+
+(define change-value
+    _ class _ -> (error "cannot change the class of an instance!~%")
+    [ ] _ _ -> (error "no such attribute!~%")
+    [[Attribute | _] | Instance] Attribute Value 
+     -> [[Attribute | Value] | Instance]
+    [Slot | Instance] Attribute Value 
+    -> [Slot | (change-value Instance Attribute Value)])
+
+(define instance-of
+    [[class | Class] | _] -> Class
+    _ -> (error "not a class instance!"))  

data/shen/release/test_programs/depth_.shen

@@ -0,0 +1,14 @@
+(define depth'
+  {A --> (A --> (list A)) --> (A --> boolean) --> (A --> boolean) --> (list A)}
+  State Successors Goal? Fail? -> (depth-help' [State] Successors Goal? Fail? []))
+
+(define depth-help'
+  {(list A) --> (A --> (list A)) --> (A --> boolean) --> (A --> boolean) --> (list A) --> (list A)}
+  [State | _] _ Goal? _ Path -> (reverse [State | Path]) 	where (Goal? State)
+  [State | _] _ _ Fail? _ -> [] 				where (Fail? State)
+  [State | _] Successors Goal? Fail? Path <- (fail-if empty? 
+                                                      (depth-help' (Successors State) 
+                                                                   Successors Goal? Fail? [State | Path]))
+  [_ | States] Successors Goal? Fail? Path -> (depth-help' States Successors Goal? Fail? Path)
+  _ _ _ _ _ -> []) 
+

data/shen/release/test_programs/einstein.shen

@@ -0,0 +1,33 @@
+(defprolog einsteins_riddle
+  Fish_Owner <-- (einstein Houses Fish_Owner);)
+
+(defprolog einstein
+   Houses Fish_Owner <-- (unify Houses [[house norwegian _ _ _ _] _ [house _ _ _ milk _] _ _])
+                         (member [house brit _ _ _ red] Houses)
+                         (member [house swede dog _ _ _] Houses)
+                         (member [house dane _ _ tea _] Houses)
+                         (iright [house _ _ _ _ green] [house _ _ _ _ white] Houses)
+                         (member [house _ _ _ coffee green] Houses)
+                         (member [house _ bird pallmall _ _] Houses)
+                         (member [house _ _ dunhill _ yellow] Houses)
+                         (next_to [house _ _ dunhill _ _] [house _ horse _ _ _] Houses)
+                         (member [house _ _ _ milk _] Houses)
+                         (next_to [house _ _ marlboro _ _] [house _ cat _ _ _] Houses)
+                         (next_to [house _ _ marlboro _ _] [house _ _ _ water _] Houses)
+                         (member [house _ _ winfield beer _] Houses)
+                         (member [house german _ rothmans _ _] Houses)
+                         (next_to [house norwegian _ _ _ _] [house _ _ _ _ blue] Houses)
+                         (unify Houses [[house norwegian _ _ _ _] _ [house _ _ _ milk _] _ _])
+                         (member [house Fish_Owner fish _ _ _] Houses);)
+
+(defprolog member
+ X [X | _] <--;
+ X [_ | Z] <-- (member X Z);)
+
+(defprolog next_to
+  X Y List <-- (iright X Y List);
+  X Y List <-- (iright Y X List);)
+
+(defprolog iright
+  L R [L | [R | _]] <--;
+  L R [_ | Rest] <-- (iright L R Rest);)

data/shen/release/test_programs/fruit_machine.shen

@@ -0,0 +1,46 @@
+(define return-fruit  
+   0 -> cherry  
+   1 -> cherry  
+   2 -> cherry  
+   3 -> cherry  
+   4 -> cherry  
+   5 -> pear  
+   6 -> pear  
+   7 -> pear  
+   8 -> pear  
+   9 -> orange  
+   10 -> orange  
+   11 -> orange  
+   12 -> pineapple  
+   13 -> pineapple  
+   14 -> lemon)
+
+(define spin-wheel 
+  -> (return-fruit (random 14))) 
+
+(define payoff  
+  cherry cherry cherry -> 60  
+  pear pear pear -> 100  
+  orange orange orange -> 200  
+  pineapple pineapple pineapple -> 300  
+  lemon lemon lemon -> 500  
+  cherry cherry X -> 10  
+  X cherry cherry -> 10  
+  pear pear X -> 20  
+  X pear pear -> 20  
+  orange orange X -> 30  
+  X orange orange -> 30  
+  pineapple pineapple X -> 40
+  X pineapple pineapple -> 40
+  lemon lemon X -> 50
+  X lemon lemon -> 50
+  X Y Z -> 0) 
+
+(define fruit-machine
+   start -> (announce-payoff  (spin-wheel) (spin-wheel) (spin-wheel)))
+
+(define announce-payoff 
+   Fruit1 Fruit2 Fruit3 
+   -> (output "~A ~A ~A~%You win ~A pence~%" 
+                     Fruit1 Fruit2 Fruit3 (payoff Fruit1 Fruit2 Fruit3)))
+

data/shen/release/test_programs/interpreter.shen

@@ -0,0 +1,219 @@
+(datatype num
+
+ ____________________________________
+ (number? X)  : verified >> X : number;)
+
+(datatype primitive_object
+
+      if (variable? X)
+      _______________
+      X : variable;
+
+      X : variable;
+      _____________
+      X : primitive_object;
+     
+      X : symbol;
+      ___________
+      X : primitive_object;
+
+      X : string;
+      ___________
+      X : primitive_object;
+
+      X : boolean;
+      ___________
+      X : primitive_object;
+
+      X : number;
+      ___________
+      X : primitive_object;
+
+      _____________________
+      [] : primitive_object;)
+
+(datatype pattern
+
+   X : primitive_object;
+   ___________
+   X : pattern;
+      
+   P1 : pattern; P2 : pattern;
+   ===========================
+   [cons P1 P2] : pattern;
+    
+   P1 : pattern; P2 : pattern;
+   ===========================
+   [@p P1 P2] : pattern;)
+
+  (datatype l_formula
+
+   X : pattern;
+   _____________
+   X : l_formula;
+      
+   X : l_formula; Y : l_formula; Z : l_formula;
+   =================================
+   [if X Y Z] : l_formula;
+
+   X : variable; Y : l_formula; Z : l_formula;
+   ================================
+   [let X Y Z] : l_formula;
+      
+   X : l_formula; Y : l_formula;
+   ======================
+   [cons X Y] : l_formula;
+      
+   X : l_formula; Y : l_formula;
+   ======================
+   [@p X Y] : l_formula;
+   
+   X : l_formula; Y : l_formula;
+   ======================
+   [where X Y] : l_formula;
+      
+   X : l_formula; Y : l_formula;
+   ======================
+   [= X Y] : l_formula;
+      
+   X : l_formula; Y : l_formula;
+   ======================
+   [X Y] : l_formula;
+      
+   Xn : (list l_formula);
+   ===================
+   [cases | Xn] : l_formula;
+      
+   P : pattern; X : l_formula;
+   ===========================
+   [/. P X] : l_formula;)
+
+(define l_interpreter
+  {A --> B}
+  _ -> (read_eval_print_loop (output "~%L interpreter ~%~%~%~%l-interp --> ~A~%" 
+                                     (normal_form (input+ : l_formula)))))
+
+(define read_eval_print_loop
+  {string --> A}
+  _ -> (read_eval_print_loop 
+           (output "l-interp --> ~A~%"
+              (normal_form (input+ : l_formula))))) 
+
+(define normal_form
+  {l_formula --> l_formula}
+   X -> (fix ==> X))                 
+    
+(define ==>
+   {l_formula --> l_formula}
+   [= X Y] -> (let X* (normal_form X) 
+                   (let Y* (normal_form Y) 
+                        (if (or (eval_error? X*) (eval_error? Y*))
+                            "error!"
+                            (if (= X* Y*) true false))))
+   [[/. P X] Y] -> (let Match (match P (normal_form Y))
+                        (if (no_match? Match) 
+                            "no match"
+                            (sub Match X))) 
+   [if X Y Z] -> (let X* (normal_form X)
+                      (if (= X* true)
+                          Y
+                          (if (= X* false)
+                              Z
+                              "error!")))
+   [let X Y Z] -> [[/. X Z] Y]
+   [@p X Y] -> (let X* (normal_form X)
+                    (let Y* (normal_form Y)
+                         (if (or (eval_error? X*) (eval_error? Y*))
+                             "error!"
+                             [@p X* Y*])))
+   [cons X Y] -> (let X* (normal_form X)
+                      (let Y* (normal_form Y)
+                           (if (or (eval_error? X*) (eval_error? Y*))
+                               "error!"
+                               [cons X* Y*])))
+   [++ X] -> (successor (normal_form X))
+   [-- X] -> (predecessor (normal_form X))
+   \*[cases X1 | Xn] -> (let Case1 (normal_form X1)
+                           (if (= Case1 "no match")
+                               [cases | Xn]
+                               Case1))
+   [cases] -> "error!"            
+   [where X Y] -> [if X Y "no match"]
+   [y-combinator [/. X Y]] -> (replace X [y-combinator [/. X Y]] Y)
+   [X Y] -> (let X* (normal_form X)
+               (let Y* (normal_form Y)
+                  (if (or (eval_error? X*) (eval_error? Y*))
+                      "error!"
+                      [X* Y*])))*\
+    X -> X)
+
+(define eval_error?
+  {l_formula --> boolean}
+   "error!" -> true
+   "no match" -> true
+   _ -> false)  
+
+(define successor
+  {A --> l_formula}
+  X -> (+ 1 X) where (number? X)
+  _ -> "error!")
+
+(define predecessor
+  {A --> l_formula}
+  X -> (- X 1) where (number? X)
+  _ -> "error!")
+
+\* (spy +) *\
+
+(define sub
+  {[(pattern * l_formula)] --> l_formula --> l_formula}
+   [] X -> X
+   [(@p Var Val) | Assoc] X -> (sub Assoc (replace Var Val X)))
+
+(define match
+   {pattern --> l_formula --> (list (pattern * l_formula))}
+    P X -> [] where (== P X)
+    P X -> [(@p P X)]      where (variable? P)
+    [cons P1 P2] [cons X Y] -> (let Match1 (match P1 X)
+                                    (if (no_match? Match1)
+                                        Match1
+                                        (let Match2 (match P2 Y)
+                                            (if (no_match? Match2)
+                                                Match2
+						(append Match1 Match2)))))
+    [@p P1 P2] [@p X Y] -> (let Match1 (match P1 X)
+                                    (if (no_match? Match1)
+                                        Match1
+                                        (let Match2 (match P2 Y)
+                                            (if (no_match? Match2)
+                                                Match2
+						(append Match1 Match2)))))
+
+    _ _ -> [(@p no matching)])
+      
+(define no_match?
+  {[(pattern * l_formula)] --> boolean}
+   [(@p no matching)] -> true
+   _ -> false)
+
+(define replace
+   {pattern --> l_formula --> l_formula --> l_formula}
+    V W [let V* X Y] -> [let V* X Y]  where (== V V*)
+    X Y X -> Y
+    V W [= X Y] -> [= (replace V W X) (replace V W Y)]
+    V W [/. P X] -> [/. P (replace V W X)] 		where (free? V P)
+    V W [if X Y Z] -> [if (replace V W X) (replace V W Y) (replace V W Z)]
+    V W [let X Y Z] -> [let X (replace V W Y) (replace V W Z)]
+    V W [@p X Y] -> [@p (replace V W X) (replace V W Y)]
+    V W [cons X Y] -> [cons (replace V W X) (replace V W Y)]
+    V W [cases | Xn] -> [cases | (map (/. Xi (replace V W Xi)) Xn)]
+    V W [where X Y] -> [where (replace V W X) (replace V W Y)]
+    V W [X Y] -> [(replace V W X) (replace V W Y)] 
+    _ _ X -> X) 	
+
+(define free?
+  {pattern --> pattern --> boolean}
+   P P -> false 
+   P [cons P1 P2] -> (and (free? P P1) (free? P P2))
+   P [@p P1 P2] -> (and (free? P P1) (free? P P2))
+   _ _ -> true)

data/shen/release/test_programs/metaprog.shen

@@ -0,0 +1,85 @@
+(define parse
+  D Sentence -> (let Parse (D [Sentence []])
+                   (if (parsed? Parse) (output_parse Parse) ungrammatical)))
+
+(define parsed?
+  [[] Output] -> true
+  _ -> false)
+
+(define output_parse
+  [_ Output] -> Output)
+
+(define generate_parser
+  Grammar -> (map compile_rules (group_rules (parenthesise_rules Grammar))))
+
+(define parenthesise_rules
+  [S --> | Rest] -> (parenthesise_rules1 [S -->] Rest))
+
+(define parenthesise_rules1
+  Rule [] -> [Rule]
+  Rule [S --> | Rest] -> [Rule | (parenthesise_rules1 [S -->] Rest)]
+  Rule [X | Y] -> (parenthesise_rules1 (append Rule [X]) Y))
+
+(define group_rules
+  Rules -> (group_rules1 Rules []))
+
+(define group_rules1
+  [] Groups -> Groups
+  [Rule | Rules] Groups -> (group_rules1 Rules (place_in_group Rule Groups)))
+
+(define place_in_group
+  Rule [] -> [[Rule]]
+  Rule [Group | Groups] -> [[Rule | Group] | Groups]
+        where (belongs-in? Rule Group)
+  Rule [Group | Groups] -> [Group | (place_in_group Rule Groups)])
+
+(define belongs-in?
+  [S | _] [[S | _] | _] -> true
+  _ _ -> false)
+
+(define compile_rules
+  Rules -> (if (lex? Rules)
+               (generate_code_for_lex Rules)
+               (generate_code_for_nonlex Rules)))
+
+(define lex?
+  [[S --> Terminal] | _] -> (string? Terminal)
+  _ -> false)
+
+(define generate_code_for_nonlex
+  Rules -> (eval (append [define (get_characteristic_non_terminal Rules) 
+                                   | (mapapp gcfn_help Rules)] 
+                         [(protect X) -> [fail]])))
+
+(define mapapp
+  _ [] -> []
+  F [X | Y] -> (append (F X) (mapapp F Y)))
+
+(define get_characteristic_non_terminal
+  [[CNT | _] | _] -> CNT)
+
+(define gcfn_help
+   Rule -> [(protect Parameter)
+            <-
+            (apply_expansion Rule
+                             [listit [head (protect Parameter)]
+                                   [cons [listit | Rule]
+                                         [head [tail (protect Parameter)]]]])])
+ 
+(define apply_expansion
+   [CNT --> | Expansion] Parameter -> (ae_help Expansion Parameter))
+
+(define ae_help
+   [] Code -> Code
+   [NT | Expansion] Code -> (ae_help Expansion [NT Code]))
+
+(define generate_code_for_lex
+  Rules -> (eval (append [define (get_characteristic_non_terminal Rules)
+                                   (protect X) -> [fail]  where [= (protect X) [fail]]
+                                   | (mapapp gcfl_help Rules)]
+                                   [(protect X) -> [fail]])))
+
+(define gcfl_help
+  [CNT --> Terminal] -> [[cons [cons Terminal (protect P)] [cons (protect Parse) []]]
+                          -> [listit (protect P) [cons [listit CNT --> Terminal] (protect Parse)]]])
+