shen-ruby 0.12.1 → 0.13.0

data/shen/release/benchmarks/einstein.shen

@@ -1,33 +0,0 @@
-(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/benchmarks/interpreter.shen

@@ -1,219 +0,0 @@
-(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 (function ==>>) 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/benchmarks/jnk.shen

@@ -1,194 +0,0 @@
-(define kl-to-lisp
-   Params Param -> Param    where (element? Param Params)
-   Params [type X _] -> (kl-to-lisp Params X)
-   Params [lambda X Y] -> [FUNCTION [LAMBDA [X] (kl-to-lisp [X | Params] Y)]] 
-   Params [let X Y Z] -> [LET [[X (kl-to-lisp Params Y)]] 
-                                 (kl-to-lisp [X | Params] Z)]
-   _ [defun F Params Code] -> [DEFUN F Params (kl-to-lisp Params Code)]
-   Params [cond | Cond] -> [COND | (map (/. C (cond_code Params C)) (insert-default Cond))]  
-   Params [Param | X] -> (higher-order-code Param
-                                (map (/. Y (kl-to-lisp Params Y)) X))
-                                        where (element? Param Params)
-   Params [[X | Y] | Z] -> (higher-order-code (kl-to-lisp Params [X | Y])
-                                               (map (/. W (kl-to-lisp Params W)) Z))   
-   Params [F | X] -> (assemble-application F 
-                                     (map (/. Y (kl-to-lisp Params Y)) X))
-                                 where (symbol? F)
-   _ [] -> []                              
-   _ S -> [QUOTE S]  where (or (symbol? S) (boolean? S))
-   _ X -> X)
-
-(define insert-default
-  [] -> [[true [ERROR "error: cond failure~%"]]]
-  [[true X] | Y] -> [[true X] | Y] 
-  [Case | Cases] -> [Case | (insert-default Cases)])    
-   
-(define higher-order-code 
-   F X -> [let Args [LIST | X]
-            [let NewF [maplispsym F]
-               [trap-error [APPLY NewF Args] 
-                           [lambda E [COND [[arity-error? F Args] 
-                                            [funcall [EVAL [nest-lambda F NewF]] Args]]
-                                           [[EQ NewF [QUOTE or]]
-                                            [funcall [lambda X1 [lambda X2 [or X1 X2]]] Args]]
-                                           [[EQ NewF [QUOTE and]]
-                                            [funcall [lambda X1 [lambda X2 [and X1 X2]]] Args]]
-                                           [[EQ NewF [QUOTE trap-error]]
-                                            [funcall [lambda X1 [lambda X2 [trap-error X1 X2]]] Args]]
-                                           [[bad-lambda-call? NewF Args] 
-                                            [funcall NewF Args]]
-                                           [T [relay-error E]]]]]]])
-                                           
-(define bad-lambda-call?
-  F Args -> (AND (FUNCTIONP F) (NOT (= (LIST-LENGTH Args) 1))))
-                                         
-(define relay-error
-  E -> (ERROR (error-to-string E)))
-                                         
-(define funcall
-  Lambda [] -> Lambda
-  Lambda [X | Y] -> (funcall (FUNCALL Lambda X) Y))   
-  
-(define arity-error?
-   F Args -> (AND (SYMBOLP F)
-                  (> (trap-error (arity F) (/. E -1)) (LIST-LENGTH Args)))       
-   
-(define nest-lambda
-   F NewF -> (nest-lambda-help NewF (trap-error (arity F) (/. E -1))))
-   
-(define nest-lambda-help
-  F -1 -> F
-  F 0 -> F
-  F N -> (let X (gensym (protect Y))
-                 [lambda X (nest-lambda-help (add-p F X) (- N 1))]))
-  
-(define add-p
-  [F | X] Y -> (append [F | X] [Y])
-  F X -> [F X])           
- 
-(define cond_code
-   Params [Test Result] -> [(lisp_test Params Test) 
-                             (kl-to-lisp Params Result)])
-                             
-(define lisp_test
-   _ true -> T
-   Params [and | Tests] -> [AND | (map (/. X (wrap (kl-to-lisp Params X))) Tests)]
-   Params Test -> (wrap (kl-to-lisp Params Test))) 
-   
- (define wrap 
-    [cons? X] -> [CONSP X]
-    [string? X] -> [STRINGP X]
-    [number? X] -> [NUMBERP X]
-    [empty? X] -> [NULL X]
-    [and P Q] -> [AND (wrap P) (wrap Q)]
-    [or P Q] -> [OR (wrap P) (wrap Q)] 
-    [not P] -> [NOT (wrap P)] 
-    [equal? X []] -> [NULL X]
-    [equal? [] X] -> [NULL X]
-    [equal? X [Quote Y]] -> [EQ X [Quote Y]]    
-                              where (and (= (SYMBOLP Y) T) (= Quote QUOTE))
-    [equal? [Quote Y] X] -> [EQ [Quote Y] X]    
-                                where (and (= (SYMBOLP Y) T) (= Quote QUOTE)) 
-    [equal? [fail] X] -> [EQ [fail] X]
-    [equal? X [fail]] -> [EQ X [fail]]
-    [equal? S X] -> [EQUAL S X]  where (string? S)
-    [equal? X S] -> [EQUAL X S]  where (string? S)
-    [equal? X Y] -> [shen-ABSEQUAL X Y]
-    [shen-+string? [tlstr X]] -> [NOT [STRING-EQUAL [tlstr X] ""]]
-    [shen-pvar? X] -> [AND [ARRAYP X] [NOT [STRINGP X]] [EQ [AREF X 0] [QUOTE shen-pvar]]] 
-    [tuple? X] -> [AND [ARRAYP X] [NOT [STRINGP X]] [EQ [AREF X 0] [QUOTE shen-tuple]]]
-    [greater? X Y] -> [> X Y]
-    [greater-than-or-equal-to? X Y] -> [>= X Y]
-    [less? X Y] -> [< X Y]
-    [less-than-or-equal-to? X Y] -> [<= X Y]
-    X -> [wrapper X])
-
- (define wrapper
-   true -> T
-   false -> []
-   X -> (error "boolean expected: not ~S~%" X)) 
-   
- (define assemble-application
-   hd [X] -> (protect [CAR X])
-   tl [X] -> (protect [CDR X])
-   cons [X Y] -> (protect [CONS X Y])
-   append [X Y] -> (protect [APPEND X Y])
-   reverse [X] -> (protect [REVERSE X])
-   if [P Q R] -> (protect [IF (wrap P) Q R])
-   + [1 X] -> [1+ X]
-   + [X 1] -> [1+ X]
-   - [X 1] -> [1- X]
-   value [[Quote X]] -> X  where (= Quote (protect QUOTE))
-   set [[Quote X] [1+ X]] -> [INCF X]  where (= Quote (protect QUOTE))
-   set [[Quote X] [1- X]] -> [DECF X]  where (= Quote (protect QUOTE))
-   F X -> (let NewF (maplispsym F)
-               Arity (trap-error (arity F) (/. E -1))
-               (if (or (= Arity (length X)) (= Arity -1))
-                   [NewF | X]
-                   [funcall (nest-lambda F NewF) [(protect LIST) | X]])))
-                   
-(define maplispsym  
-    = -> equal?
-    > -> greater?
-    < -> less?
-    >= -> greater-than-or-equal-to?
-    <= -> less-than-or-equal-to?
-    + -> add
-    - -> subtract
-    / -> divide
-    * -> multiply
-    F -> F)
-    
- (define factorh
-  [Defun F Params [Cond | Code]] -> [Defun F Params [BLOCK [] (process-tree (tree (map returns Code)))]]
-                                       where (and (= Cond COND) (= Defun DEFUN))
-  Code -> Code)
-  
-(define returns
-  [Test Result] -> [Test [RETURN Result]]) 
-    
-(define process-tree
-   (@p P Q R no-tag) -> [IF P (optimise-selectors P (process-tree Q)) (process-tree R)]
-   (@p P Q R Tag) -> [TAGBODY [IF P (optimise-selectors P (process-tree Q))] Tag (process-tree R)]
-   Q -> Q    where (not (tuple? Q))) 
-   
-(define optimise-selectors 
-  Test Code -> (optimise-selectors-help (selectors-from Test) Code))                       
-
-(define selectors-from
-  [Consp X] -> [[CAR X] [CDR X]]    where (= Consp CONSP)
-  [tuple? X] -> [[fst X] [snd X]]  
-  _ -> [])    
-  
-(define optimise-selectors-help 
-   [] Code -> Code
-   [S1 S2] Code -> (let O1 (occurrences S1 Code)  
-                        O2 (occurrences S2 Code) 
-                        V1 (gensym V)
-                        V2 (gensym V)
-                        (if (and (> O1 1) (> O2 1))
-                            [LET [[V1 S1] [V2 S2]]  
-                                 (subst V1 S1 (subst V2 S2 Code))]
-                            (if (> O1 1)
-                                 [LET [[V1 S1]] (subst V1 S1 Code)] 
-                                 (if (> O2 1)
-                                      [LET [[V2 S2]] (subst V2 S2 Code)]
-                                      Code)))))        
-
-(define tree
-  [[[And P Q] R] | S] ->  (let Tag (gensym tag)
-                                Left (tree (append (branch-by P [[[And P Q] R] | S]) [[T [GO Tag]]]))
-                                Right (tree (branch-by-not P [[[And P Q] R] | S]))                                
-                                (@p P Left Right Tag))     where (= And AND)                 
-  [[True Q] | _] -> Q     where (= True T)                         
-  [[P Q] | R] -> (@p P Q (tree R) no-tag))
-  
-(define branch-by
-  P [[[And P Q] R] | S] -> [[Q R] | (branch-by P S)]   where (= And AND)
-  P [[P R] | S] -> [[T R]]
-  _ Code -> [])
-  
-(define branch-by-not
-  P [[[And P Q] R] | S] -> (branch-by-not P S)  where (= And AND)
-  P [[P R] | S] -> S
-  _ Code -> Code)