shen-ruby 0.1.0

data/shen/release/test_programs/proplog_version_1.shen

@@ -0,0 +1,25 @@
+(define backchain  
+   Conc Assumptions -> (backchain* [Conc] Assumptions Assumptions))
+
+(define backchain* 
+   [] _ _ -> proved 
+   [[P & Q] | Goals] _ Assumptions 
+   -> (backchain* [P Q | Goals] Assumptions Assumptions) 
+   [P | Goals] [[P <= | Subgoal] | _] Assumptions  
+   <- (backchain* (append Subgoal Goals) Assumptions Assumptions)  
+   Goals [_ | Rest] Assumptions -> (backchain* Goals Rest Assumptions)  
+   _ _ _ -> (fail)) 
+
+
+
+
+
+
+
+
+
+
+
+
+ 
+

data/shen/release/test_programs/proplog_version_2.shen

@@ -0,0 +1,27 @@
+(define backchain  
+   Conc Assumptions -> (backchain* Conc Assumptions Assumptions))
+
+(define backchain*
+   P [P | _] _ -> true
+   [P & Q] _ Assumptions
+   -> (and (backchain* P Assumptions Assumptions)
+           (backchain* Q Assumptions Assumptions))
+   P [[P <= Q] | _] Assumptions
+   <- (fail-if (/. X (= X false)) (backchain* Q Assumptions Assumptions))
+   P [_ | Rest] Assumptions -> (backchain* P Rest Assumptions)
+   _ _ _ -> false)
+
+
+
+
+
+
+
+
+
+
+
+
+
+ 
+

data/shen/release/test_programs/qmachine.shen

@@ -0,0 +1,67 @@
+(datatype progression
+
+	X : A; S : (A --> A); E : (A --> boolean);
+	==========================================
+	[X S E] : (progression A);)
+
+(define force
+ {(progression A) --> A}
+  [X S E] -> X)
+
+(define delay
+  {(progression A) --> (progression A)}
+    [X S E] -> [(S X) S E])
+ 
+(define end?
+  {(progression A) --> boolean}
+   [X S E] -> (E X)) 
+
+(define push
+  {A --> (progression A) --> (progression A)}
+  X [Y S E] -> [X (/. Z (if (= Z X) Y (S Z))) E]) 
+
+(define forall
+  {(progression A) --> (A --> boolean) --> boolean}
+   [X S E] P -> (if (E X) true (and (P X) (forall [(S X) S E] P))))
+
+(define exists
+  {(progression A) --> (A --> boolean) --> boolean}
+  [X S E] P -> (if (E X) false (or (P X) (exists [(S X) S E] P))))
+
+(define super
+  {(progression A) --> (A --> B) --> (B --> C --> C) --> C --> C}
+   [X S E] P F Y -> (if (E X) Y (F (P X) (super [(S X) S E] P F Y))))
+
+(define forall
+  {(progression A) --> (A --> boolean) --> boolean}
+   Progression P -> (super Progression P and true)) 
+
+(define exists
+  {(progression A) --> (A --> boolean) --> boolean}
+   Progression P -> (super Progression P or false)) 
+
+(define for
+  {(progression A) --> (A --> B) --> number}
+   Progression P -> (super Progression P progn 0))
+
+(define progn
+  {A --> B --> B}
+   X Y -> Y)
+
+(define filter
+  {(progression A) --> (A --> boolean) --> (list A)}
+  Progression P -> (super Progression (/. X (if (P X) [X] [])) append []))
+
+(define next-prime
+  {number --> number}
+  N -> (if (prime? (+ N 1)) (+ N 1) (next-prime (+ N 1))))
+
+(define prime?
+  {number --> boolean}
+  X -> (prime-help X (/ X 2) 2))
+
+(define prime-help
+  {number --> number --> number --> boolean}
+   X Max Div -> false 		where (integer? (/ X Div))
+   X Max Div -> true 		where (> Div Max)
+   X Max Div -> (prime-help X Max (+ 1 Div)))

data/shen/release/test_programs/red-black.shen

@@ -0,0 +1,55 @@
+\**\ \* Copyright (c) 2011, Justin Grant <justin at imagine27 dot com> *\ \* All rights reserved. *\ \**\ \* Redistribution and use in source and binary forms, with or without modification,  *\ \* are permitted provided that the following conditions are met: *\ \**\ \* Redistributions of source code must retain the above copyright notice, this list  *\ \* of conditions and the following disclaimer. *\ \* Redistributions in binary form must reproduce the above copyright notice, this  *\ \* list of conditions and the following disclaimer in the documentation and/or  *\ \* other materials provided with the distribution. *\ \* Neither the name of the <ORGANIZATION> nor the names of its contributors may be  *\ \* used to endorse or promote products derived from this software without specific  *\ \* prior written permission. *\ \**\ \* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND  *\ \* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED *\ \* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE  *\ \* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR  *\ \* ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES  *\ \* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *\ \* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  *\ \* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING  *\ \* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,  *\ \* EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *\ \**\  (datatype tree-node
+
+    Key : number; Val : B;
+    ======================
+    [Key Val] : tree-node;)
+
+(datatype color
+
+    if (element? Color [red black])
+    _______________________________
+    Color : color;)
+
+(datatype tree
+
+    if (empty? Tree)
+    ________________
+    Tree : tree;
+
+    Color : color; LTree : tree; TreeNode : tree-node; RTree : tree;
+    ================================================================
+    [Color LTree TreeNode RTree] : tree;)
+
+(define node-key
+    {tree-node --> number}
+    [Key Val] -> Key)
+
+(define make-tree-black
+    {tree --> tree}
+    [Color A X B] -> [black A X B])
+
+(define member
+    {tree-node --> tree --> boolean}
+    X [] -> false
+    X [Color A Y B] -> (cases (< (node-key X) (node-key Y)) (member X A)
+                              (< (node-key Y) (node-key X))  (member X B)
+                              true true))
+
+(define balance
+    {tree --> tree}
+    [black [red [red A X B] Y C] Z D] -> [red [black A X B] Y [black C Z D]]
+    [black [red A X [red B Y C]] Z D] -> [red [black A X B] Y [black C Z D]]
+    [black A X [red [red B Y C] Z D]] -> [red [black A X B] Y [black C Z D]]
+    [black A X [red B Y [red C Z D]]] -> [red [black A X B] Y [black C Z D]]
+    S -> S)
+
+(define insert-
+    {tree-node --> tree --> tree}
+    X [] -> [red [] X []]
+    X [Color A Y B] -> (cases (< (node-key X) (node-key Y)) (balance [Color (insert- X A) Y B])
+                              (< (node-key Y) (node-key X)) (balance [Color A Y (insert- X B)])
+                              true [Color A Y B]))
+
+(define insert
+  {tree-node --> tree --> tree}
+  X S -> (make-tree-black (insert- X S)))

data/shen/release/test_programs/search.shen

@@ -0,0 +1,56 @@
+(define breadth-first
+   {state --> (state --> (list state)) --> (state --> boolean) --> boolean}
+    Start F Test -> (b* F Test (F Start))) 
+
+(define b*
+   {(state --> (list state)) --> (state --> boolean) --> (list state) --> boolean}
+    F Test States -> true 	where (some Test States)
+    F Test States -> (let NewStates (mapcan F States)
+                              (if (empty? NewStates)
+                                  false
+                                  (b* F Test NewStates))))
+
+(define some
+  {(A --> boolean) --> (list A) --> boolean}
+   Test [] -> false
+   Test [X|Y] -> (or (Test X) (some Test Y)))
+
+(define depth
+  {state --> (state --> (list state)) --> (state --> boolean) --> boolean}
+    Start _ Test -> true 	where (Test Start)
+    Start F Test -> (d* F Test (F Start))) 
+
+(define d*
+   {(state --> (list state)) --> (state --> boolean) --> (list state) --> boolean}
+    _ Test [State | _] -> true 	where (Test State)
+    F Test [State | States] <- (fail-if (= false) (d* F Test (F State)))
+    F Test [_ | States] -> (d* F Test States)
+    _ _ _ -> false)
+
+(define hill
+  {(state --> number) --> state --> (state --> (list state)) --> (state --> boolean) --> boolean}
+    _ Start _ Test -> true 	where (Test Start)
+    E Start F Test -> (h* E F Test (order_states E (F Start))))  
+
+(define h*
+   {(state --> number) --> (state --> (list state)) --> (state --> boolean) --> (list state) --> boolean}
+    _ _ Test [State | _] -> true 	where (Test State)
+    E F Test [State | States] 
+    <- (fail-if (/. X (= X false)) (h* E F Test (order_states E (F State))))
+    E F Test [_ | States] -> (h* E F Test States)
+    _ _ _ _ -> false)    
+    
+(define order_states
+  {(state --> number) --> (list state) --> (list state)}
+   E States -> (sort (/. S1 (/. S2 (> (E S1) (E S2)))) States))
+
+(define sort
+  {(A --> (A --> boolean)) --> (list A) --> (list A)}
+   R X -> (fix (/. Y (sort* R Y)) X))
+
+(define sort*
+   {(A --> A --> boolean) --> (list A) --> (list A)}
+    _ [] -> []
+    _ [X] -> [X]
+    R [X Y | Z] -> [Y | (sort* R [X | Z])]	where (R Y X)
+    R [X Y | Z] -> [X | (sort* R [Y | Z])])

data/shen/release/test_programs/semantic_net.shen

@@ -0,0 +1,44 @@
+(define query  
+  [is Object Concept] -> (if (belongs? Object Concept) yes no))
+
+(define belongs?  
+  Object Concept -> (element? Concept (fix spread-activation [Object])))
+
+(define spread-activation  
+  [] -> [] 
+  [Vertex | Vertices] -> (union (accessible-from Vertex)
+                                (spread-activation Vertices)))
+
+(define accessible-from  
+  Vertex -> [Vertex | (union (is_links Vertex) (type_links Vertex))])
+
+(define is_links  
+  Vertex -> (get-prop Vertex is_a []))
+
+(define type_links 
+  Vertex -> (get-prop Vertex type_of []))
+
+(define assert
+   [Object is_a Type] -> (put Object is_a [Type | (is_links Object)])
+   [Type1 type_of Type2] -> (put Type1 type_of [Type2 | (type_links Type1)]))
+
+(define get-prop
+  Ob Pointer Default -> (trap-error (get Ob Pointer) (/. E Default)))
+
+(define clear
+  Ob -> (put Ob is_a (put Ob type_of [])))
+
+
+
+
+
+
+
+
+
+
+
+
+
+ 
+

data/shen/release/test_programs/spreadsheet.shen

@@ -0,0 +1,35 @@
+(define assess-spreadsheet
+  Spreadsheet -> (map (/. Row (assign-fixed-values Row Spreadsheet))
+                      Spreadsheet))
+
+(define assign-fixed-values 
+   [Index | Cells] Spreadsheet 
+   -> [Index | (map (/. Cell (assign-cell-value Cell Spreadsheet)) Cells)]) 
+
+(define assign-cell-value 
+   [Attribute Value]  _ -> [Attribute Value] where (fixed-value? Value) 
+   [Attribute Value] Spreadsheet -> [Attribute (Value Spreadsheet)])
+
+(define fixed-value?
+ \* number?, symbol? and string? are system functions - see appendix A *\
+  Value -> (or (number? Value) (or (symbol? Value) (string? Value))))
+
+(define get'
+  \* spreads the spreadsheet! *\
+  Index Attribute Spreadsheet
+   -> (get-row Index Attribute Spreadsheet Spreadsheet))
+
+(define get-row
+   \* looks for the right row using the index *\
+   Index Attribute [[Index | Cells] | _] Spreadsheet
+   -> (get-cell Attribute Cells Spreadsheet)
+   Index Attribute [_ | Rows] Spreadsheet
+   -> (get-row Index Attribute Rows Spreadsheet)
+   Index _ _ _ -> (error "Index ~A not found" Index))
+
+(define get-cell
+   Attribute [[Attribute Value] | _] Spreadsheet 
+   -> (if (fixed-value? Value) Value (Value Spreadsheet))
+   Attribute [_ | Cells] Spreadsheet
+   -> (get-cell Attribute Cells Spreadsheet)
+   Attribute _ _ -> (error "Attribute ~A not found" Attribute))

data/shen/release/test_programs/stack.shen

@@ -0,0 +1,27 @@
+(declare empty-stack [A --> [stack B]])
+
+(declare push [A --> [stack A] --> [stack A]])
+
+(declare top [[stack A] --> A])
+
+(declare pop [[stack A] --> [stack A]])
+
+(define empty-stack
+   _ -> (/.  X (if (or (= X pop) (= X top))
+                        (error "this stack is empty~%")
+                        (error "~A is not an operation on stacks.~%" X))))
+                        
+(define push
+   X S -> (/. Y (if (= Y pop) 
+                    S 
+                   (if (= Y top) 
+                       X 
+                       (error "~A is not an operation on stacks.~%" Y)))))
+
+(define top
+   S -> (S top))
+
+(define pop
+   S -> (S pop))
+
+

data/shen/release/test_programs/streams.shen

@@ -0,0 +1,20 @@
+(datatype progression
+
+    X : (A * (A --> A) * (A --> boolean));
+    ======================================
+    X : (progression A);)    
+
+(define delay
+   {(progression A) --> (progression A)}
+   (@p X F E) -> (if (not (E X)) 
+                     (@p (F X) F E) 
+                     (error "progression exhausted!~%")))
+
+(define force
+    {(progression A) --> A}
+     (@p X F E) -> X)
+
+(define end?
+    {(progression A) --> boolean}
+     (@p X _ E) -> (E X))
+

data/shen/release/test_programs/strings.shen

@@ -0,0 +1,59 @@
+\* Replace the first occurrence of a string Rem by Rep *\
+(define subst-string
+  {string --> string --> string --> string}
+   _ _ "" -> ""
+  Rep (@s S Ss) (@s S Ss') <- (fail-if (= "failed!") (subst-string' Rep Ss Ss'))
+  Rep Rem (@s S Ss) -> (@s S (subst-string Rep Rem Ss)))
+  
+(define subst-string'
+  {string --> string --> string --> string}
+  Rep "" Ss -> (@s Rep Ss)
+  Rep (@s S Ss) (@s S Ss') -> (subst-string' Rep Ss Ss')
+   _ _ _ -> "failed!")
+   
+   
+(define rwilli
+  {string --> string}
+  "" -> ""
+  (@s "Willi" Ss) -> (rwilli Ss)
+  (@s _ Ss) -> (rwilli Ss))
+  
+
+\* Length of a string. *\   
+(define strlen
+   {string --> number}
+    "" -> 0
+    (@s _ S) -> (+ 1 (strlen S)))
+    
+\* Trim characters from the front of a string. *\    
+(define trim-string-left
+   {(list string) --> string --> string}
+     _ "" -> ""
+     Trim (@s S Ss) -> (@s S Ss)  where (not (element? S Trim))
+     Trim (@s _ Ss) -> (trim-string-left Trim Ss)) 
+
+\* Trim characters from the end of a string. *\      
+(define trim-string-right
+   {(list string) --> string --> string}          
+     Trim S -> (reverse-string (trim-string-left Trim (reverse-string S))))
+     
+\* Trim characters from the front and end of a string *\
+(define trim-string
+   {(list string) --> string --> string}          
+     Trim S -> (reverse-string (trim-string-left Trim (reverse-string (trim-string-left Trim S)))))     
+
+\* Reverse a string. *\    
+(define reverse-string
+  {string --> string}
+   "" -> ""
+   (@s S Ss) -> (@s (reverse-string Ss) S))   
+
+\* A string of digits? *\ 
+(define alldigits?
+   {string --> boolean}
+   "" -> true
+   (@s S Ss) -> (and (digit? S) (alldigits? Ss)))
+   
+(define digit?
+  {string --> boolean}
+   S -> (element? S ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9"]))   

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

@@ -0,0 +1,71 @@
+(define defstruct
+  Name Slots 
+  -> (let Attributes (map fst Slots)
+          Types (map snd Slots)
+          Selectors (selectors Name Attributes)
+          Constructor (constructor Name Attributes)
+          Recognisor (recognisor Name)
+          ConstructorType (constructor-type Name Types)
+          SelectorTypes (selector-types Name Attributes Types)
+          RecognisorType (recognisor-type Name)
+          Name))
+
+(define selector-types
+  _ [] [] -> (gensym (protect X))
+  Name [Attribute | Attributes] [Type | Types] 
+  -> (let Selector (concat Name (concat - Attribute))
+          SelectorType [Name --> Type] 
+          TypeDecl (declare Selector SelectorType)
+          (selector-types Name Attributes Types)))
+
+(define recognisor-type
+  Name -> (let Recognisor (concat Name ?)
+                        (declare Recognisor [Name --> boolean])))
+
+(define constructor-type
+  Name Types -> (let Constructor (concat make- Name)
+                     Type (assemble-type Types Name)
+                     (declare Constructor Type)))
+
+(define assemble-type
+  [ ] Name -> Name
+  [Type | Types] Name -> [Type --> (assemble-type Types Name)])
+
+(declare defstruct [symbol --> [list [symbol * symbol]] --> symbol])
+
+(define selectors
+    Name Attributes -> (map (/. A (selector Name A)) Attributes))
+
+(define selector
+    Name Attribute 
+    -> (let SelectorName (concat Name (concat - Attribute))
+           (eval [define SelectorName
+                   (protect Structure) -> [let (protect LookUp) [assoc Attribute (protect Structure)]
+                                     [if [empty? (protect LookUp)]
+                                         [error "~A is not an attribute of ~A.~%" 
+                                                    Attribute Name]
+                                         [tail (protect LookUp)]]]])))
+
+(define constructor
+   Name Attributes 
+   -> (let ConstructorName (concat make- Name)
+           Parameters (params Attributes)
+           (eval [define ConstructorName |
+                    (append Parameters 
+                            [-> [cons [cons structure Name] 
+                                      (make-association-list Attributes
+                                                             Parameters)]])])))
+
+(define params
+   [] -> []
+   [_ | Attributes] -> [(gensym (protect X)) | (params Attributes)])
+
+(define make-association-list
+   [] [] -> []
+   [A | As] [P | Ps] -> [cons [cons A P] (make-association-list As Ps)])
+
+(define recognisor
+  Name -> (let RecognisorName (concat Name ?)
+               (eval [define RecognisorName 
+                       [cons [cons structure Name] _] -> true
+                        _ -> false])))