shen-ruby 0.1.0

data/shen/release/test_programs/TinyLispFunctions.txt

@@ -0,0 +1,16 @@
+(defun plus (x y)
+  (lispif (equal x 0) 
+           y
+           (plus (prec x) (succ y))))
+
+(defun member (x y)
+   (lispif (equal y (empty!)) 
+           (empty!)
+           (lispif (equal x (car y)) 
+                   y
+                   (member x (cdr y)))))
+
+(defun join (x y)
+   (lispif (equal x (empty!))
+            y
+            (lispcons (car x) (join (cdr x) y))))

data/shen/release/test_programs/TinyTypes.shen

@@ -0,0 +1,55 @@
+(specialise defun)
+(specialise lambda')
+
+(datatype tiny_lisp_type_theory
+
+  let Lambda (mk_lambda Xs Body)
+  F : A >> Lambda : A;
+  __________________
+  (defun F Xs Body) : A;
+
+  let X* (gensym &&x)
+  let Y* (subst X* X Y)
+  X* : A >> Y* : B;
+  _____________________
+  (lambda' (X) Y) : (A --> B);
+
+  F : (A --> B); X : A;
+  ________________
+  (F X) : B;
+
+  ____________________________
+  lispif : (bool --> (A --> (A --> A)));
+
+  ________________________
+  equal : (A --> (A --> bool));
+
+  ___________________________
+  lispcons : (A --> ((list A) --> (list A)));
+
+  ______________
+  car : ((list A) --> A);
+
+  _______________
+  cdr : ((list A) --> (list A));
+
+  if (element? F [succ prec])
+  ____________________
+  F : (number --> number);
+
+  ___________
+  (tee!) : bool;
+
+  ____________
+  (empty!) : (list A);
+
+  ________
+  (empty!) : bool;
+
+  if (symbol? X)
+  ____________
+  (quote X) : symbol;)
+
+(define mk_lambda
+   [X] Body -> [lambda' [X] Body]
+   [X | Y] Body -> [lambda' [X] (mk_lambda Y Body)])

data/shen/release/test_programs/binary.shen

@@ -0,0 +1,24 @@
+(datatype binary
+
+if (element? X [0 1])
+_____________
+X : zero-or-one;
+
+X : zero-or-one;
+________________
+[X] : binary;
+
+X : zero-or-one; Y : binary;
+____________________________
+[X | Y] : binary;
+
+X : zero-or-one, [Y | Z] : binary >> P;
+________________________________________
+[X Y | Z] : binary >> P;)
+
+(define complement
+   {binary --> binary}
+   [0] -> [1] 
+   [1] -> [0]      
+   [1 N | X] -> [0 | (complement [N | X])] 
+   [0 N | X] -> [1 | (complement [N | X])]) 

data/shen/release/test_programs/bubble_version_1.shen

@@ -0,0 +1,28 @@
+(define bubble-sort 
+  \* bubble again if you need to *\  
+  X -> (bubble-again-perhaps (bubble X) X))
+
+(define bubble 
+  [] -> []  
+  [X] -> [X]  
+  [X Y | Z] -> [Y | (bubble [X | Z])]   where    (> Y X)
+  [X Y | Z] -> [X | (bubble [Y | Z])])
+
+(define bubble-again-perhaps  
+   \* no change as a result of bubbling - then the job is done *\  
+   X X -> X  
+  \* else bubble again *\  
+   X _ -> (bubble-sort X))
+
+
+
+
+
+
+
+
+
+
+
+ 
+

data/shen/release/test_programs/bubble_version_2.shen

@@ -0,0 +1,22 @@
+(define bubble-sort 
+  X -> (fix bubble X)) 
+
+(define bubble 
+  [] -> []  
+  [X] -> [X]  
+  [X Y | Z] -> [Y | (bubble [X | Z])]   where    (> Y X)
+  [X Y | Z] -> [X | (bubble [Y | Z])])
+
+
+
+
+
+
+
+
+
+
+
+
+ 
+

data/shen/release/test_programs/calculator.shen

@@ -0,0 +1,21 @@
+(datatype arith-expr
+
+    X : number;
+    ====================
+    [num X] : arith-expr; 
+
+    if (element? Op [+ - * /])
+    X : arith-expr; Y : arith-expr;
+    ===============================
+    [X Op Y] : arith-expr;)
+
+(define do-calculation
+  {arith-expr --> number}
+  [X + Y] -> (+ (do-calculation X) (do-calculation Y))
+  [X - Y] -> (- (do-calculation X) (do-calculation Y))
+  [X * Y] -> (* (do-calculation X) (do-calculation Y))
+  [X / Y] -> (/ (do-calculation X) (do-calculation Y))
+  [num X] -> X)
+
+
+

data/shen/release/test_programs/cartprod.shen

@@ -0,0 +1,23 @@
+(define cartesian-product 
+   [ ] _ -> [ ]  
+   [X | Y] Z -> (append (all-pairs-using-X X Z) (cartesian-product Y Z)))
+
+(define all-pairs-using-X 
+   _ [ ] -> [ ] 
+   X [Y | Z] -> [[X Y] | (all-pairs-using-X X Z)]) 
+   
+
+   
+    
+      
+    
+      
+
+
+
+
+
+
+
+ 
+

data/shen/release/test_programs/change.shen

@@ -0,0 +1,25 @@
+(define count-change 
+    Amount -> (count-change* Amount 200))
+
+(define count-change* 
+    0 _ -> 1  
+    _ 0 -> 0  
+    Amount _ -> 0  	where (> 0 Amount)
+    Amount Fst_Denom  
+    -> (+ (count-change* (- Amount Fst_Denom) Fst_Denom) 
+          (count-change* Amount (next-denom Fst_Denom))))
+
+(define next-denom
+   200 -> 100  
+   100 -> 50  
+   50 -> 20  
+   20 -> 10  
+   10 -> 5  
+   5 -> 2  
+   2 -> 1  
+   1 -> 0)
+
+
+
+ 
+

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

@@ -0,0 +1,94 @@
+(datatype class
+
+      Slots : [slot];
+      _______________________________________
+      (defclass Class Slots) : (class Class);
+
+      Attribute : symbol; Type : symbol;
+      ===================================
+      (@p Attribute Type) : slot;
+
+      Default : Type; Attribute : symbol; Type : symbol;
+      ==================================================
+      (@p Attribute Type Default) : slot;)
+
+(define defclass
+   Class ClassDef -> (let Attributes (map fst ClassDef)
+                          Types (record-attribute-types Class ClassDef)
+                          Assoc (map assign-values ClassDef)
+                          NewClassDef [[class | Class] | Assoc]
+                          Store (put-prop Class classdef NewClassDef)
+                          RecordClass (axiom Class Class [class Class])
+                          Class))
+
+(define assign-values
+  (@p Attribute _ Value) -> [Attribute | Value]
+  (@p Attribute _) -> [Attribute | fail!])                                
+
+(define axiom
+  DataType X A -> (eval [datatype DataType
+                                  ________
+                                   X : A;]))
+
+(define record-attribute-types
+  _ [] -> []
+  Class [(@p Attribute Type _) | ClassDef]
+   -> (let DataTypeName (concat Class Attribute)
+           DataType (axiom DataTypeName Attribute [attribute Class Type])
+           (record-attribute-types Class ClassDef))
+  Class [(@p Attribute Type) | ClassDef] 
+   -> (let DataTypeName (concat Class Attribute)
+           DataType (axiom DataTypeName Attribute [attribute Class Type])
+           (record-attribute-types Class ClassDef)))         
+                                            
+(declare make-instance [[class Class] --> [instance Class]])
+
+(define make-instance
+   Class -> (let ClassDef (get-prop Class classdef [])
+                 (if (empty? ClassDef)
+                     (error "class ~A does not exist~%" Class)
+                     ClassDef))) 
+
+(declare get-value [[attribute Class A] --> [instance Class] --> A])
+
+(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) 
+
+(declare has-value? [[attribute Class A] --> [instance Class] --> boolean])
+
+(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) 
+
+(declare has-attribute? [symbol --> [instance Class] --> boolean])
+
+(define has-attribute?
+  Attribute Instance -> (let LookUp (assoc Attribute Instance)
+                             (not (empty? LookUp))))
+
+(declare change-value [[instance Class] --> [attribute Class A] --> A --> [instance Class]])
+
+(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)])
+
+(declare instance-of [[instance Class] --> [class Class]])
+
+(define instance-of
+    [[class | Class] | _] -> Class
+    _ -> (error "not a class instance!"))

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

@@ -0,0 +1,100 @@
+(declare defclass [symbol --> [list [class A]] --> [list [symbol * symbol]] --> symbol])
+
+(datatype subtype
+
+  (subtype B A); X : B;
+  _____________________
+  X : A;)
+
+(define defclass
+   Class SuperClasses ClassDef 
+    -> (let Attributes (map fst ClassDef)
+            Inherited (put-prop Class attributes 
+                        (append Attributes (collect-attributes SuperClasses)))
+            Types (record-attribute-types Class ClassDef)
+            Assoc (map (/. Attribute [Attribute | fail!]) Inherited)
+            ClassDef [[class | Class] | Assoc]
+            Store (put-prop Class classdef ClassDef)
+            RecordClass (axiom Class Class [class Class])
+            SubTypes (record-subtypes Class SuperClasses)
+            Class))
+
+(define record-subtypes
+  _ [] -> _
+  Class SuperClasses -> (eval [datatype (concat Class superclasses)
+                                 | (record-subtypes-help Class SuperClasses)]))
+
+(define record-subtypes-help
+  _ [] -> []
+  Class [SuperClass | SuperClasses] -> [_______________________
+                                        [subtype SuperClass Class]; | 
+                                          (record-subtypes-help Class SuperClasses)])
+                              
+(define collect-attributes
+  [] -> []
+  [SuperClass | SuperClasses] -> (append (get-prop SuperClass attributes [])
+                                         (collect-attributes SuperClasses)))
+
+(define axiom
+  DataType X A -> (eval [datatype DataType
+                                  ________
+                                   X : A;]))
+
+(define record-attribute-types
+  _ [] -> []
+  Class [(@p Attribute Type) | ClassDef] 
+   -> (let DataTypeName (concat Class Attribute)
+           DataType (axiom DataTypeName Attribute [attribute Class Type])
+           (record-attribute-types Class ClassDef)))         
+                                        
+(declare make-instance [[class Class] --> [instance Class]])
+
+(define make-instance
+   Class -> (let ClassDef (get-prop Class classdef [])
+                 (if (empty? ClassDef)
+                     (error "class ~A does not exist~%" Class)
+                     ClassDef))) 
+
+(declare get-value [[attribute Class A] --> [instance Class] --> A])
+
+(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) 
+
+(declare has-value? [[attribute Class A] --> [instance Class] --> boolean])
+
+(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) 
+
+(declare has-attribute? [symbol --> [instance Class] --> boolean])
+
+(define has-attribute?
+  Attribute Instance -> (let LookUp (assoc Attribute Instance)
+                             (not (empty? LookUp))))
+
+(declare change-value [[instance Class] --> [attribute Class A] --> A --> [instance Class]])
+
+(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)])
+
+(declare instance-of [[instance Class] --> [class Class]])
+
+(define instance-of
+    [[class | Class] | _] -> Class
+    _ -> (error "not a class instance!"))

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

@@ -0,0 +1,74 @@
+(declare defclass [symbol --> [list [symbol * symbol]] --> symbol])
+
+(define defclass
+   Class ClassDef -> (let Attributes (map fst ClassDef)
+                          Types (record-attribute-types Class ClassDef)
+                          Assoc (map (/. Attribute [Attribute | fail]) Attributes)
+                          ClassDef [[class | Class] | Assoc]
+                          Store (put Class classdef ClassDef)
+                          RecordClass (axiom Class Class [class Class])
+                          Class))
+
+(define axiom
+  DataType X A -> (eval [datatype DataType
+                                  ________
+                                   X : A;]))
+
+(define record-attribute-types
+  _ [] -> []
+  Class [(@p Attribute Type) | ClassDef] 
+   -> (let DataTypeName (concat Class Attribute)
+           DataType (axiom DataTypeName Attribute [attribute Class Type])
+           (record-attribute-types Class ClassDef)))         
+                                        
+(declare make-instance [[class Class] --> [instance Class]])
+
+(define make-instance
+   Class -> (let ClassDef (trap-error (get Class classdef) (/. E []))
+                 (if (empty? ClassDef)
+                     (error "class ~A does not exist~%" Class)
+                     ClassDef))) 
+
+(declare get-value [[attribute Class A] --> [instance Class] --> A])
+
+(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) 
+
+(declare has-value? [[attribute Class A] --> [instance Class] --> boolean])
+
+(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) 
+
+(declare has-attribute? [symbol --> [instance Class] --> boolean])
+
+(define has-attribute?
+  Attribute Instance -> (let LookUp (assoc Attribute Instance)
+                             (not (empty? LookUp))))
+
+(declare change-value [[instance Class] --> [attribute Class A] --> A --> [instance Class]])
+
+(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)])
+
+(declare instance-of [[instance Class] --> [class Class]])
+
+(define instance-of
+    [[class | Class] | _] -> Class
+    _ -> (error "not a class instance!"))