shen-ruby 0.1.0

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

@@ -0,0 +1,42 @@
+(define defstruct
+  Name Attributes -> (let Selectors (selectors Name Attributes)
+                          Constructor (constructor Name Attributes)
+                          Recognisor (recognisor Name)
+                          Name))
+
+(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])))

data/shen/release/test_programs/tests.shen

@@ -0,0 +1,294 @@
+(maxinferences 10000000000)
+
+(report prolog-tests
+   (defprolog f
+     a <--;)   f 
+   (prolog? (f a)) true
+   (defprolog g
+     a <-- ! (f b);
+     X <-- (f a);) g
+    (prolog? (g a)) false
+    (prolog? (g b)) true
+   (defprolog mem
+      X [X | _] <--;
+      X [Y | Z] <-- (mem X Z);)  mem
+    (prolog? (mem 1 [X | 2]) (return X)) 1
+    (defprolog app 
+      [] X X <--;
+      [X | Y] W [X | Z] <-- (app Y W Z);) app
+    (defprolog rev
+      [] [] <--;
+      [X | Y] Z <-- (rev Y W) (app W [X] Z);) rev
+     (prolog? (rev [1 2] X) (return X)) [2 1]
+     (load "einstein.shen") loaded
+     (prolog? (einsteins_riddle X) (return X)) german 
+     (defprolog enjoys
+        willi X <-- (likes mark X);
+        mark chocolate <--;
+        mark tea <--;) enjoys
+     (prolog? (enjoys mark X) (return X)) chocolate  
+     (defprolog fads
+       X <-- (findall Y [enjoys X Y] Friends) (return Friends);) fads
+     (prolog? (fads mark)) [tea chocolate]
+     (defprolog prop
+        A C <-- (proph [[~  C] | A]);) prop
+     (defprolog proph
+       A <-- (mem [~ P] A) (mem P A) !;
+       A <-- (consistent A) ! (when false);
+       (mode [[P & Q] | A] -) <-- ! (proph [P Q | A]);
+       (mode [[P <=> Q] | A] -) <-- ! (proph [[P => Q] [Q => P] | A]);
+       (mode [[P => Q] | A] -) <-- ! (proph [[[~ P] v Q] | A]);
+       (mode [[~ [P v Q]] | A] -)  <-- ! (proph [[~ P] [~ Q] | A]);
+       (mode [[~ [P & Q]] | A] -) <-- ! (proph [[[~ P] v [~ Q]] | A]);
+       (mode [[~ [P => Q]] | A] -) <-- ! (proph [P [~ Q] | A]);
+       (mode [[~ [P <=> Q]] | A] -) <-- ! (proph [[~ [[P => Q] v [~ [Q => P]]]] | A]);
+       (mode [[P & Q] | A] -) <-- !  (proph [P Q | A]);
+       (mode [[P v Q] | A] -) <-- !  (proph [P | A]) ! (proph [Q | A]);
+       (mode [P | Ps] -) <-- (app Ps [P] Qs) ! (proph Qs);) proph
+      (defprolog consistent
+         [] <--;
+         [P | Ps] <-- (when (symbol? P)) ! (consistent Ps);
+         [[~ P] | Ps] <-- (when (symbol? P)) ! (consistent Ps);) consistent
+      (defprolog app
+         [] X X <--;
+         (mode [X | Y] -) W [X | Z] <-- (app Y W Z);) app
+      (defprolog mem
+         X (mode [X | _] -) <--;
+         X (mode [_ | Y] -) <-- (mem X Y);) mem 
+      (prolog? (prop [] [p <=> p]))  true 
+      (defprolog mapit
+         _  []  [] <--;
+         Pred [X | Y] [W | Z] <-- (call [Pred X W])  (mapit Pred Y Z);) mapit
+       (defprolog consit
+         X [1 X] <--;) consit
+        (prolog? (mapit consit [1 2 3] Out) (return Out)) 
+                 [[1 1] [1 2] [1 3]] 
+        (defprolog different
+          X Y <--  (~ [identical X Y]);) different
+        (defprolog ~
+          P <-- (call P) ! (when false);
+          _ <--;) ~
+        (prolog? (different a b)) true 
+        (prolog? (different a a)) false 
+        (defprolog likes
+           john  X <-- (tall X)  (pretty X);) likes
+        (defprolog tall
+           mary <--;) tall
+        (defprolog pretty
+           mary <--;) pretty
+        (prolog? (likes john Who) (return Who)) mary 
+        (load "parse.prl") loaded
+        (prolog? (pparse ["the" + ["boy" + "jumps"]] 
+                        [[s = [np + vp]] 
+                          [np = [det + n]]
+                          [det = "the"]
+                          [n = "girl"]
+                          [n = "boy"]
+                          [vp = vintrans]
+                          [vp = [vtrans + np]]
+                          [vintrans = "jumps"]
+                          [vtrans = "likes"]
+                          [vtrans = "loves"]])) true)
+
+\* (report "FPQi chapter 2"
+   (load "fruit_machine.shen") loaded
+   (do (print (fruit-machine start)) ok) ok) *\
+    
+  
+(report "FPQi chapter 4"
+    (load "cartprod.shen") loaded
+    (cartesian-product [1 2 3] [1 2 3]) 
+                          [[1 1] [1 2] [1 3] [2 1] [2 2] [2 3] [3 1] [3 2] [3 3]]
+    (load "powerset.shen") loaded
+    (powerset [1 2 3]) [[1 2 3] [1 2] [1 3] [1] [2 3] [2] [3] []])
+     
+(do (set *sprd* )   
+     (nl 2))   
+    
+(report "FPQi chapter 5"
+
+  (load "bubble_version_1.shen") loaded
+   (bubble-sort [1 2 3])  [3 2 1]
+   (load "bubble_version_2.shen") loaded 
+   (bubble-sort [1 2 3]) [3 2 1]
+  \* (load "newton_version_1.shen") loaded
+   (newtons-method 4) 2
+   (load "newton_version_2.shen") loaded 
+   (newtons-method 4) 2 *\
+   (load "spreadsheet.shen") loaded 
+   (assess-spreadsheet [[jim [wages (/. Spreadsheet (get' frank wages Spreadsheet))]
+                             [tax (/. Spreadsheet (* (get' frank tax Spreadsheet) .8))]]
+                        [frank [wages 20000]
+                               [tax (/. Spreadsheet (* .25 (get' frank wages Spreadsheet)))]]])
+              
+              [[jim [wages 20000] [tax 4000.0]] [frank [wages 20000] [tax 5000.0]]]   ) 
+
+(report "FPQi chapter 3"
+    
+      (load "prime.shen") loaded
+      (prime? 1000003) true
+      (load "mutual.shen") loaded
+      (even? 56) true
+      (odd? 77)  true 
+      (load "change.shen") loaded
+      (count-change 100) 4563
+      )
+    
+(report "FPQi chapter 6"
+   (load "semantic_net.shen") loaded
+    (clear Mark_Tarver) []
+    (clear man) []
+    (assert [Mark_Tarver is_a man]) [man] 
+    (assert [man type_of human]) [human]
+    (query [is Mark_Tarver human]) yes) 
+    
+(report "FPQi chapter 7"
+   
+     (load "proplog_version_1.shen") loaded 
+     (backchain q [[q <= p] [q <= r] [r <=]]) proved 
+     (backchain q [[q <= p] [q <= r]]) (fail)
+     (load "proplog_version_2.shen") loaded 
+     (backchain q [[q <= p] [q <= r] r]) true 
+     (backchain q [[q <= p] [q <= r]]) false
+      )  
+           
+(report "FPQi chapter 8"   
+    
+    (load "metaprog.shen") loaded 
+    (generate_parser [sent --> np vp  np --> name  np  --> det n 
+              name --> "John"  name --> "Bill"  
+              name --> "Tom" det  --> "the"  det  --> "a"
+              det  --> "that" det  --> "this"  
+              n --> "girl"  n --> "ball" 
+              vp --> vtrans np  vp --> vintrans  
+              vtrans --> "kicks" vtrans --> "likes"
+              vintrans --> "jumps" vintrans --> "flies"]) [sent np name det n vp vtrans vintrans]
+    
+     )   
+     
+(report "chapter 11"
+     (load "binary.shen") loaded
+     (complement [1 0]) [0 1]
+     (load "streams.shen") loaded
+     (fst (delay (@p 0 (+ 1) (/. X false)))) 1)
+       
+ (report "strings"
+     (load "strings.shen") loaded
+     (subst-string "a" "b" "cba") "caa"
+     (strlen "123") 3
+     (trim-string-left [" "] " hi ") "hi "
+     (trim-string-right [" "] " hi ") " hi"
+     (trim-string [" "] " hi ") "hi"
+     (reverse-string "abc") "cba" 
+     (alldigits? "123") true)    
+
+ (report "calculator.shen - chapter 11"
+     (load "calculator.shen") loaded
+     (do-calculation [[num 12] + [[num 7] * [num 4]]]) 40 )      
+     
+(report "structures 1 - chapter 12"
+    (load "structures-untyped.shen") loaded
+    (defstruct ship [length name]) ship
+    (make-ship 200 "Mary Rose")  [[structure | ship] [length | 200] [name | "Mary Rose"]]
+    (ship-length (make-ship 200 "Mary Rose")) 200
+    (ship-name (make-ship 200 "Mary Rose"))  "Mary Rose" ) 
+
+(report "structures 2 - chapter 12"
+  (load "structures-typed.shen") loaded
+  (defstruct ship [(@p length number) (@p name string)]) ship
+  (make-ship 200 "Mary Rose")  [[structure | ship] [length | 200] [name | "Mary Rose"]]
+  (ship-length (make-ship 200 "Mary Rose")) 200
+  (ship-name (make-ship 200 "Mary Rose"))  "Mary Rose") 
+    
+(report "classes 1 - chapter 12"
+   (load "classes-untyped.shen") loaded
+   (defclass ship [length name]) ship
+   (set s (make-instance ship)) [[class | ship] [length | fail] [name | fail]]
+   (has-value? length (value s)) false
+   (set s (change-value (value s) length 100)) [[class | ship] [length | 100] [name | fail]]
+   (get-value length (value s)) 100)       
+     
+(report "classes 2 - chapter 12"
+   (load "classes-typed.shen") loaded
+   (defclass ship [(@p length number) (@p name string)]) ship
+   (has-value? length (make-instance ship)) false
+   (change-value (make-instance ship) length 100) [[class | ship] [length | 100] [name | fail]]
+   (get-value length (change-value (make-instance ship) length 100)) 100)       
+     
+ (report "abstract datatypes - chapter 12"
+   (load "stack.shen") loaded
+   (top (push 0 (empty-stack _))) 0
+    ) 
+    
+ (report "yacc"
+   (load "yacc.shen") loaded
+   (compile <sent> [the cat likes the dog]) [the cat likes the dog]
+   (compile <sent> [the cat likes the canary]) (fail)
+   (compile <asbscs> [a a a b b c])  [a a a b b c]
+   (compile <find-digit> [a v f g 6 y u]) [6]
+   (compile <vp> [chases the cat]) [chases the cat]
+   (compile <des> [[d] [e e]]) [d e e]
+   (compile <sent'> [the cat likes the dog]) [is it true that your father likes the dog ?]
+   (compile <as> [a a a]) [a a a]
+   (compile <find-digit'> [a v f g 6 y u]) [6 y u]
+   (compile <asbs'cs> [a v f g 6 y u]) (fail)
+   (compile <find-digit''> [a v f g 6 y u]) 6
+   (compile <anbncn> [a a a b b b c c c]) [a a a b b b c c c] )
+      
+(preclude-all-but [])    
+(tc +)       
+
+(report "N Queens"
+     (preclude-all-but [])  []
+     (tc +) true
+     (load "n_queens.shen") loaded
+     (n-queens 5) [[4 2 5 3 1] [3 5 2 4 1] [5 3 1 4 2] [4 1 3 5 2] [5 2 4 1 3] [1 4 2 5 3] 
+                    [2 5 3 1 4] [1 3 5 2 4] [3 1 4 2 5] [2 4 1 3 5]]
+     (tc -) false) 
+        
+(report "search"
+     (tc +) true
+     (load "search.shen") loaded
+     (tc -) false) 
+
+(report "whist - chapter 11"
+     (tc +) true
+     (load "whist.shen") loaded
+     (tc -) false)      
+      
+(report "Qi interpreter - chapter 13"
+     (tc +) true
+     (load "interpreter.shen") loaded
+     (tc -) false)           
+ 
+(report "proof assistant - chapter 15"
+   (tc +) true
+   (load "proof_assistant.shen") loaded
+   (tc -) false)
+
+(report "quantifier machine"
+   (tc +) true
+   (load "qmachine.shen") loaded
+   \* (filter [1 (+ 1) (= 100)] (/. X (integer? (sqrt X)))) [1 4 9 16 25 36 49 64 81] *\
+   (exists [1 (+ 1) (= 100)] (> 50)) true
+   (tc -) false) 
+ 
+(report "depth first search"
+   (tc +) true
+   (load "depth_.shen") loaded
+   (depth' 4 (/. X [(+ X 3) (+ X 4) (+ X 5)]) (/. X (= X 27)) (/. X (> X 27))) [4 7 10 13 16 19 22 27]
+   (depth' 4 (/. X [(+ X 3)]) (/. X (= X 27)) (/. X (> X 27))) []
+   (tc -) false) 
+
+\* (report "red/black trees"
+   (tc +) true
+   (load "red-black.shen") loaded) *\
+
+(report "Lisp type checker"
+   
+   (load "TinyTypes.shen") loaded
+   (tc +) true
+   (load "TinyLispFunctions.txt") loaded
+   (tc -) false ) 
+
+(reset)

data/shen/release/test_programs/types.shen

@@ -0,0 +1,11 @@
+(if-without-checking "switch on the typechecker first!~%")
+
+(datatype fruit
+
+   if (element? Fruit [cherry pear orange pineapple lemon])
+   _____________
+   Fruit : fruit;)
+
+
+
+

data/shen/release/test_programs/whist.shen

@@ -0,0 +1,240 @@
+(synonyms
+     card (rank * suit)
+     cscore number
+     pscore number )
+
+(datatype rank
+
+   if (element? Rank [2 3 4 5 6 7 8 9 10 11 12 13 14])
+   ___________________________________________________
+   Rank : rank;
+
+   Rank : rank;
+   ___________
+   Rank : number;)
+
+(datatype suit
+
+   if (element? Suit [c d h s])
+   ____________________________
+   Suit : suit;)
+
+(datatype lead
+
+   if (element? L [player computer])
+   _________________________________
+   L : lead;)
+
+(define whist
+    {lead --> string}
+     Lead -> (whist-loop (deal-whist 13 (deck _) (@p [] [])) 0 0 Lead))
+
+(define deck
+     {A --> (list card)}
+     _ -> (cartprod [2 3 4 5 6 7 8 9 10 11 12 13 14]  [c d h s]))
+
+(define cartprod
+     {[A] --> [B] --> [(A * B)]}
+      [] _ -> []
+      [X | Y] Z -> (append (map (/. W (@p X W)) Z) (cartprod Y Z)))
+
+(define deal-whist
+  {number --> (list card) --> ((list card) * (list card)) -->  ((list card) * (list card))}
+  0 _ (@p Computer Player) -> (@p Computer Player)
+  N Deck  (@p Computer Player) 
+  -> (let CCard (deal-card Deck)
+          Deck-1 (remove CCard Deck)
+          PCard (deal-card Deck-1)
+          Deck-2  (remove PCard Deck-1)
+          (deal-whist (- N 1) Deck-2 (@p [CCard | Computer] [PCard | Player]))))
+
+(define deal-card
+   {(list card) --> card}
+     Cards -> (nth (+ (random (length Cards)) 1) Cards))
+
+(define random
+  {A --> A}
+   X -> X) 
+
+(define whist-loop
+  {((list card) * (list card)) --> cscore --> pscore --> lead --> string}
+  Hands Cscore Pscore _ 
+  -> (if (> Cscore Pscore)
+         (output "~%Computer tricks: ~A, Player tricks: ~A; ~%Computer wins!~%"
+                 Cscore Pscore)
+         (output "~%Computer tricks: ~A, Player tricks: ~A; ~%You win!~%" 
+                 Cscore Pscore))      
+			where (game-over? Hands) 
+  (@p Computer Player) Cscore Pscore computer
+       -> (let Ccard (computer-shows (play-computer-lead Computer)) 
+               Pcard (determine-legal (play-player Player) Ccard Player)
+               Winner (return-winner (determine-winner Ccard Pcard computer))
+               Computer-1 (remove Ccard Computer)
+               Player-1 (remove Pcard Player)
+               (if (= Winner computer)
+                   (whist-loop (@p Computer-1 Player-1) 
+                               (+ 1 Cscore) 
+                               Pscore 
+                               computer) 
+                   (whist-loop (@p Computer-1 Player-1) 
+                               Cscore 
+                               (+ Pscore 1) 
+                               player)))
+     (@p Computer Player) Cscore Pscore player 
+          -> (let Pcard (play-player Player)
+                  Ccard (computer-shows (play-computer-follow Computer Pcard))
+                  Winner (return-winner (determine-winner Ccard Pcard player))
+                  Computer-1 (remove Ccard Computer)
+                  Player-1 (remove Pcard Player)
+                  (if (= Winner computer)
+                      (whist-loop (@p Computer-1 Player-1) 
+                                  (+ 1 Cscore) 
+                                  Pscore 
+                                  computer) 
+                      (whist-loop (@p Computer-1 Player-1) 
+                                  Cscore 
+                                  (+ Pscore 1) 
+                                  player)))) 
+
+(define determine-legal
+    {card --> card --> (list card) --> card}
+      Pcard Ccard Player -> Pcard		where (legal? Pcard Ccard Player)
+      _ Ccard Player -> (do (output "You must follow suit!" []) 
+		                    (determine-legal (play-player Player) 
+                                             Ccard 
+                                             Player)))
+
+(define legal?
+  {card --> card --> (list card) --> boolean}
+  (@p _ Suit) (@p _ Suit) _ -> true
+  _  (@p _ Suit) Player -> (void-of-suit? Suit Player))
+
+(define void-of-suit?
+  {suit --> (list card) --> boolean}
+  Suit Player -> (empty? (same-suit Player Suit)))
+
+(define same-suit
+  {(list card) --> suit --> (list card)}
+  [] _ -> []
+  [(@p Rank Suit) | Cards] Suit -> [(@p Rank Suit) | (same-suit Cards Suit)]
+  [_ | Cards] Suit -> (same-suit Cards Suit))
+
+(define determine-winner
+  {card --> card --> lead --> lead}
+  (@p Rank1 Suit) (@p Rank2 Suit) _ -> (if (> Rank1 Rank2) computer player)
+  _ _ Lead -> Lead)
+
+(define return-winner
+  {lead --> lead}
+  computer -> (do (output "~%Computer wins the trick.~%____________________________________________~%" []) 
+                                    computer)
+    player -> (do (output "~%Player wins the trick.~%____________________________________________~%" []) 
+                                     player))
+
+(define game-over?
+  {((list card) * (list card)) --> boolean}
+  (@p [] []) -> true
+  _ -> false)
+ 
+(define play-computer-lead
+  {(list card) --> card}
+  Cards -> (select-highest Cards))
+
+(define computer-shows
+  {card --> card}
+  (@p Rank Suit) -> (do (output "~%Computer plays the ~A of ~A~%" 
+                                (map-rank Rank) (map-suit Suit))
+                        (@p Rank Suit))) 
+
+(define map-rank
+  {rank --> string}
+  14 -> "ace"
+  13 -> "king"
+  12 -> "queen"
+  11 -> "jack"
+  N -> (make-string "~A" N)) 
+
+(define map-suit
+  {suit --> string}
+  c -> "c#5;"
+  d -> "c#4;"
+  h -> "c#3;"
+  s -> "c#6;")
+ 
+(define select-highest
+ {(list card) --> card}
+ [Card | Cards] -> (select-highest-help Card Cards))
+
+(define select-highest-help
+  {card --> (list card) --> card}
+  Card [] -> Card
+  Card1 [Card2  | Cards] 
+	-> (select-highest-help Card2 Cards)  where (higher? Card2 Card1)
+  Card [_ | Cards] -> (select-highest-help Card Cards))
+
+(define higher?
+ {card --> card --> boolean}
+ (@p Rank1 _) (@p Rank2 _) -> (> Rank1 Rank2))
+
+(define play-computer-follow
+  {(list card) --> card --> card}
+   Cards (@p Rank Suit) 
+     -> (let FollowSuit (sort lower? (same-suit Cards Suit))
+            (if (empty? FollowSuit)
+                (select-lowest Cards)
+                (let Ccard (select-higher (@p Rank Suit) FollowSuit)
+                    (if (= (determine-winner Ccard (@p Rank Suit) player) computer)
+                          Ccard
+                          (head FollowSuit))))))
+
+(define sort
+  {(A --> A --> boolean) --> (list A) --> (list A)}
+  R X -> (fix (/. Y (sort-help R Y)) X))
+
+(define sort-help
+  {(A --> A --> boolean) --> (list A) --> (list A)}
+  _ [] -> []
+  _ [X] -> [X]
+  R [X Y | Z] -> [Y | (sort-help R [X | Z])]	where (R Y X)
+  R [X | Y] -> [X | (sort-help R Y)]) 
+
+(define select-higher
+  {card --> (list card) --> card}
+   _ [Card] -> Card
+   Card1 [Card2 | _] -> Card2     where (higher? Card2 Card1)
+   Card [_ | Cards] -> (select-higher Card Cards))
+
+(define select-lowest
+  {(list card) --> card}
+  [Card | Cards] -> (select-lowest-help Card Cards))
+ 
+(define select-lowest-help 
+  {card --> (list card) --> card}
+  Card [] -> Card
+  Card1 [Card2  | Cards] 
+    -> (select-lowest-help Card2 Cards)   where (lower? Card2 Card1)
+  Card [_ | Cards] -> (select-lowest-help Card Cards))
+
+(define lower?
+  {card --> card --> boolean}
+  (@p Rank1 _) (@p Rank2 _) -> (< Rank1 Rank2))
+
+(define play-player
+  {(list card) --> card}
+  Cards -> (do (output "~%Your hand is ~%~%")
+               (show-cards 1 Cards)
+               (let N (input+ : number)
+                    (if (in-range? N Cards)
+                        (nth N Cards)
+                        (play-player Cards)))))
+
+(define show-cards
+  {number --> (list card) --> string}
+  _ [] -> (output "~%~%Choose a Card: ")
+  N [(@p Rank Suit) | Cards] 
+  -> (do (output "~%~A. ~A of ~A" N (map-rank Rank) (map-suit Suit)) 
+         (show-cards (+ N 1) Cards)))
+
+(define in-range?
+  {number --> (list card) --> boolean}
+  N Cards -> (and (integer? N) (and (> N 0) (<= N (length Cards)))))