From 38fe9e91f451d9682ff7edf65fc395b85ddde961 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 10 Feb 2015 02:04:46 -0400 Subject: Super refactoring that breaks the system: Part 1 --- source/lux.lux | 1008 +++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 747 insertions(+), 261 deletions(-) (limited to 'source/lux.lux') diff --git a/source/lux.lux b/source/lux.lux index 63ab93a4c..4a53e088b 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1,66 +1,66 @@ ## Base interfaces & classes -(jvm:interface Function +(jvm;interface Function (: apply (-> [java.lang.Object] java.lang.Object))) -(jvm:class Tuple0 java.lang.Object +(jvm;class Tuple0 java.lang.Object []) -(jvm:class Tuple1 java.lang.Object +(jvm;class Tuple1 java.lang.Object [[java.lang.Object _1]]) -(jvm:class Tuple2 java.lang.Object +(jvm;class Tuple2 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2]]) -(jvm:class Tuple3 java.lang.Object +(jvm;class Tuple3 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3]]) -(jvm:class Tuple4 java.lang.Object +(jvm;class Tuple4 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4]]) -(jvm:class Tuple5 java.lang.Object +(jvm;class Tuple5 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5]]) -(jvm:class Tuple6 java.lang.Object +(jvm;class Tuple6 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5] [java.lang.Object _6]]) -(jvm:class Tuple7 java.lang.Object +(jvm;class Tuple7 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5] [java.lang.Object _6] [java.lang.Object _7]]) -(jvm:class Tuple8 java.lang.Object +(jvm;class Tuple8 java.lang.Object [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5] [java.lang.Object _6] [java.lang.Object _7] [java.lang.Object _8]]) -(jvm:class Variant java.lang.Object +(jvm;class Variant java.lang.Object [[java.lang.String tag]]) -(jvm:class Variant0 lux.Variant +(jvm;class Variant0 lux.Variant []) -(jvm:class Variant1 lux.Variant +(jvm;class Variant1 lux.Variant [[java.lang.Object _1]]) -(jvm:class Variant2 lux.Variant +(jvm;class Variant2 lux.Variant [[java.lang.Object _1] [java.lang.Object _2]]) -(jvm:class Variant3 lux.Variant +(jvm;class Variant3 lux.Variant [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3]]) -(jvm:class Variant4 lux.Variant +(jvm;class Variant4 lux.Variant [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4]]) -(jvm:class Variant5 lux.Variant +(jvm;class Variant5 lux.Variant [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5]]) -(jvm:class Variant6 lux.Variant +(jvm;class Variant6 lux.Variant [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5] [java.lang.Object _6]]) -(jvm:class Variant7 lux.Variant +(jvm;class Variant7 lux.Variant [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5] [java.lang.Object _6] [java.lang.Object _7]]) -(jvm:class Variant8 lux.Variant +(jvm;class Variant8 lux.Variant [[java.lang.Object _1] [java.lang.Object _2] [java.lang.Object _3] [java.lang.Object _4] [java.lang.Object _5] [java.lang.Object _6] @@ -71,299 +71,785 @@ (def' lambda (lambda' _ tokens (lambda' _ state - (let' output (case tokens - (#Cons self (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil))) - (#Form (#Cons (#Ident "lambda'") - (#Cons self - (#Cons arg - (#Cons (case args' - #Nil - body - - _ - (#Form (#Cons (#Ident "lux:lambda") - (#Cons (#Tuple args') - (#Cons body #Nil))))) - #Nil))))) - - (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil)) - (#Form (#Cons (#Ident "lambda'") - (#Cons (#Ident "_") - (#Cons arg - (#Cons (case args' - #Nil - body - - _ - (#Form (#Cons (#Ident "lux:lambda") - (#Cons (#Tuple args') - (#Cons body #Nil))))) - #Nil)))))) + (let' output (case' tokens + (#Cons self (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil))) + (#Form (#Cons (#Ident "lambda'") + (#Cons self + (#Cons arg + (#Cons (case args' + #Nil + body + + _ + (#Form (#Cons (#Ident "lux;lambda") + (#Cons (#Tuple args') + (#Cons body #Nil))))) + #Nil))))) + + (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil)) + (#Form (#Cons (#Ident "lambda'") + (#Cons (#Ident "_") + (#Cons arg + (#Cons (case args' + #Nil + body + + _ + (#Form (#Cons (#Ident "lux;lambda") + (#Cons (#Tuple args') + (#Cons body #Nil))))) + #Nil)))))) [(#Cons output #Nil) state])))) (annotate def Macro) (def' def (lambda [tokens state] - (let' output (case tokens - (#Cons (#Ident name) (#Cons body #Nil)) - (#Form (#Cons (#Ident "def'") - (#Cons (#Ident name) - (#Cons body #Nil)))) - - (#Cons (#Form (#Cons (#Ident name) args)) - (#Cons body #Nil)) - (#Form (#Cons (#Ident "def'") - (#Cons (#Ident name) - (#Cons (#Form (#Cons (#Ident "lux:lambda") - (#Cons (#Ident name) - (#Cons (#Tuple args) - (#Cons body #Nil))))) - #Nil))))) - [(#Cons output #Nil) state]))) + (let' output (case' tokens + (#Cons (#Ident name) (#Cons body #Nil)) + (#Form (#Cons (#Ident "def'") + (#Cons (#Ident name) + (#Cons body #Nil)))) + + (#Cons (#Form (#Cons (#Ident name) args)) + (#Cons body #Nil)) + (#Form (#Cons (#Ident "def'") + (#Cons (#Ident name) + (#Cons (#Form (#Cons (#Ident "lux:lambda") + (#Cons (#Ident name) + (#Cons (#Tuple args) + (#Cons body #Nil))))) + #Nil))))) + [(#Cons output #Nil) state]))) (def (+ x y) - (jvm:iadd x y)) + (jvm;iadd x y)) (def (id x) x) -(def (fold f init values) - (case values - #Nil - init - - (#Cons x xs) - (fold f (f init x) xs))) +(def (print x) + (jvm;invokevirtual java.io.PrintStream "print" [Object] + (jvm;getstatic System out) [x])) -(def (reverse list) - (fold (lambda [tail head] (#Cons head tail)) +(def (println x) + (jvm;invokevirtual java.io.PrintStream "println" [Object] + (jvm;getstatic System out) [x])) + +(def (fold f init xs) + (do (print "fold ") (print init) (print " ") (println xs) + (case' xs #Nil - list)) + init + + (#Cons x xs') + (let' init' (f init x) + (do (print "init': ") (println init') + (fold f init' xs'))) + #((fold f (f init x) xs'))# + ))) + +(def (reverse list) + (do (print "reverse ") (println list) + (let' reversed (fold (lambda [tail head] + (do (print "reverse/0 ") (print "tail: ") (print tail) (print " head: ") (println head) + (#Cons head tail))) + #Nil + list) + (do (print "!reversed ") (println reversed) + reversed)))) (annotate list Macro) (def (list xs state) - (let' output (fold (lambda [tail head] - (#Form (#Cons (#Tag "Cons") - (#Cons head - (#Cons tail #Nil))))) - (#Tag "Nil") - (reverse xs)) - [(#Cons output #Nil) state])) + (let' xs' (reverse xs) + (let' output (fold (lambda [tail head] + (do (print "tail: ") (print tail) (print " head: ") (println head) + (#Form (#Cons (#Tag "Cons") + (#Cons head + (#Cons tail #Nil)))))) + (#Tag "Nil") + (do (print "REVERSED: ") (println xs') + xs')) + (do (print "output: ") (println output) + [(#Cons output #Nil) state])))) (annotate list+ Macro) (def (list+ xs state) - (case (reverse xs) + (case' (reverse xs) #Nil [#Nil state] (#Cons last init') (let' output (fold (lambda [tail head] - (#Form (#Cons (#Tag "Cons") - (#Cons head tail)))) + (#Form (#Cons (#Tag "Cons") + (#Cons head tail)))) last init') [(#Cons output #Nil) state]))) (def (->pairs xs) - (case xs + (case' xs (#Cons x (#Cons y xs')) (#Cons [x y] (->pairs xs')) _ #Nil)) -#((annotate let Macro) - (def (let tokens state) - (case tokens - (#Cons (#Tuple bindings) (#Cons body #Nil)) - (let' output (fold (lambda [body binding] - (case binding - [label value] - (#Form (list (#Ident "let'") label value body)))) - body - (reverse (->pairs bindings))) - [(list output) state]))))# - (annotate let Macro) (def (let tokens state) - (case tokens - (#Cons (#Tuple bindings) (#Cons body #Nil)) - (let' output (fold (lambda [body binding] - (case binding - [label value] - (#Form (#Cons (#Ident "let'") (#Cons label (#Cons value (#Cons body #Nil))))))) - body - (reverse (->pairs bindings))) - [(list output) state]))) - -(def (++ xs ys) - (case xs + (case' tokens + (#Cons (#Tuple bindings) (#Cons body #Nil)) + (let' output (fold (lambda [body binding] + (case binding + [label value] + (#Form (list (#Ident "let'") label value body)))) + body + (reverse (->pairs bindings))) + [(list output) state]))) + +(def (++-list xs ys) + (case' xs #Nil ys (#Cons x xs*) - (#Cons x (++ xs* ys)))) + (#Cons x (++-list xs* ys)))) -(def (map f xs) - (case xs +(def (map-list f xs) + (case' xs #Nil #Nil (#Cons x xs*) - (#Cons (f x) (map f xs*)))) + (#Cons (f x) (map-list f xs*)))) #( - (def (untemplate-list untemplate tokens) - (case tokens - #Nil - (#Tag "Nil") +(def (untemplate-list untemplate tokens) +(case tokens +#Nil +(#Tag "Nil") + +(#Cons token tokens') +(#Form (list (#Tag "Cons") (untemplate token) (untemplate-list untemplate tokens'))))) + +(def (untemplate token) +(case token +(#Bool elem) +(#Form (list (#Tag "Bool") (#Bool elem))) + +(#Int elem) +(#Form (list (#Tag "Int") (#Int elem))) + +(#Real elem) +(#Form (list (#Tag "Real") (#Real elem))) + +(#Char elem) +(#Form (list (#Tag "Char") (#Char elem))) - (#Cons token tokens') - (#Form (list (#Tag "Cons") (untemplate token) (untemplate-list untemplate tokens'))))) +(#Text elem) +(#Form (list (#Tag "Text") (#Text elem))) - (def (untemplate token) - (case token - (#Bool elem) - (#Form (list (#Tag "Bool") (#Bool elem))) +(#Tag elem) +(#Form (list (#Tag "Tag") (#Text elem))) - (#Int elem) - (#Form (list (#Tag "Int") (#Int elem))) +(#Ident elem) +(#Form (list (#Tag "Ident") (#Text elem))) - (#Real elem) - (#Form (list (#Tag "Real") (#Real elem))) +(#Form (#Cons (#Ident "~") (#Cons unquoted #Nil))) +unquoted + +(#Tuple elems) +(#Form (list (#Tag "Tuple") (untemplate-list untemplate elems))) + +(#Form elems) +(#Form (list (#Tag "Form") (untemplate-list untemplate elems))) +)) + + +## I/O +(def (print x) +(jvm;invokevirtual java.io.PrintStream "print" [Object] +(jvm;getstatic System out) [x])) + +(def (println x) +(jvm;invokevirtual java.io.PrintStream "println" [Object] +(jvm;getstatic System out) [x])) + +(annotate ' Macro) +(def (' form) +(case form +(#Cons token #Nil) +(untemplate token))) + +(def (+ x y) +(jvm;iadd x y)) + +(def inc (+ 1)) + +(def length (fold (lambda' l (lambda' x (inc l))) 0)) + +(def (rem dividend divisor) +(jvm;irem dividend divisor)) + +(def (= x y) +(jvm;invokevirtual Object "equals" [Object] +x [y])) + +(def (pairs list) +(case list +(#Cons x (#Cons y list*)) +(#Cons [x y] (pairs list*)) + +_ +#Nil)) + +(def (show x) +(jvm;invokevirtual Object "toString" [] +x [])) + +(def (concat t1 t2) +(jvm;invokevirtual String "concat" [String] +t1 [t2])) + +(def (range from to) +(if (= from to) +#Nil +(#Cons from (range (inc from) to)))) + +(def (text->list text) +(let' length (jvm;invokevirtual String "length" [] +text []) +(map (lambda' idx +(jvm;invokevirtual String "charAt" [int] +text [idx])) +(range 0 length)))) + +(def (enumerate list) +(case (fold (lambda' state +(lambda' x +(case state +[idx list'] +[(inc idx) (#Cons [idx x] list')]))) +[0 #Nil] +list) +[_ list'] +(reverse list'))) + +(def list-map #Nil) + +(def (put key val map) +(case map +#Nil +(#Cons [key val] map) + +(#Cons [?key ?val] map') +(if (= key ?key) +(#Cons [?key val] map') +(#Cons [?key ?val] (put key val map'))))) + +(def (get key map) +(case map +#Nil +#None + +(#Cons [?key ?val] map') +(if (= key ?key) +(#Some ?val) +(get key map')))) + +(def (show-kv kv) +(case kv +[?key ?val] +(fold concat "" (list "#" ?key " " (show ?val))))) + +(def (interpose elem list) +(case list +(#Cons x (#Cons y list')) +(list+ x elem y (interpose elem list')) + +_ +list)) + +(def (show-list xs) +(case xs +#Nil +"#Nil" + +(#Cons x xs') +(fold concat "" (list "(#Cons " (show x) " " (show-list xs') ")")))) + +(defsig (Equal x) +(: = (-> x x Bool))) + +(deftype Equal (All [x r] {#= (-> x x Bool) & r})) +(deftype Equal (All [x] {#= (-> x x Bool)})) +(deftype Equal (All [x] (Exists [r] {#= (-> x x Bool) & r}))) + +(defimpl (Equal Bool) +(def (= x y) +(case [x y] +[ true true] true +[false false] true +_ false))) + +(def Equal_Bool +(struct {#= [(-> Bool Bool Bool) +(lambda [x y] ...)]})) + +(: (~ g!Equal) (Equal Bool)) +(: (~ g!Equal) {#= (-> Bool Bool Bool)}) +(def (~ g!Equal) +{#= (lambda [x y] ...)}) + +(def Equal_List +(lambda [Equal_x] +(struct {#= }))) + +(: Equal_List +(All [x] (-> (Equal x) (Equal (List x))))) + +(defimpl (All [x] +(=> [(Equal x)] +(Equal (List x)))) +(def (= xs1 xs2) +(case [xs1 xs2] +[#Nil #Nil] +true + +[(#Cons x1 xs1') (#Cons x2 xs2')] +(and (Equal_x x1 x2) (= xs1' xs2'))))) + +(All [x] +(-> (Equal x) (Equal (List x)))) + +(EqualList EqualBool) => {#= ...} + +(: ops (List (Exists [a] [(-> Text a) (-> a [])]))) +(def ops (list [(lambda [_] 10) (lambda [_] [])] +[(lambda [_] "") (lambda [_] [])])) + +(case ops +#Nil +[] + +(#Cons [f1 f2] ops') +(f2 (f1 "E"))) + +(defsig (Add x) +(: + (-> x x x))) + +(defimpl AddInt (Add Int) +#defs +(def (+ x y) +(jvm;ladd x y))) + +(defimpl (Add Int) +(def (+ x y) +(jvm;ladd x y))) + +(: adder (All [x] (=> [(Add x)] +(-> x (-> x x))))) +(def (adder by) +(lambda [x] (+ by x))) + +(adder AddInt 1) -> (lambda [x] ((get@ #+ AddInt) 1 x)) +adder == (lambda [impl] +(case impl +{#+ +} +(lambda [x] (+ by x)))) + +(: calc (All [v] +(-> (-> v Int) +(| (#Add Int Int) (#Mul Int Int) & v) +Int))) +(def (calc backup expr) +(case expr +(#Add x y) (+ x y) +(#Mul x y) (* x y) +else (backup else))) + +(defsig Yolo +(: lol? (-> Text Bool)) +(: foo Int)) + +(defimpl Meme [Yolo] +(def (lol? _) true) +(def foo 10)) + +(defimpl Nyan [Yolo] +Meme +(def foo 20)) + +(list 1 2 3) == (#Cons 1 (#Cons 2 (#Cons 3 #Nil))) +(list+ 1 2 (list 3)) + +(defsig (Monoid a) +(: empty a) +(: ++ (BinaryOp a))) + +(: concat (All [a] +(=> [(Monoid a)] +(-> (List a) a)))) +(def (concat mon +xs) +(fold (:: mon #++) (:: mon #empty) xs)) + +(defstruct (Monoid Text) +(def empty "") +(def (++ x y) +...)) + +(defstruct (All [a] +(Monoid (List a))) +(def empty (list)) +(def (++ xs ys) +(case xs +#Nil +ys - (#Char elem) - (#Form (list (#Tag "Char") (#Char elem))) +(#Cons x xs') +(#Cons x (++ xs' ys))))) - (#Text elem) - (#Form (list (#Tag "Text") (#Text elem))) +(: map (All [a b] (-> (-> a b) (List a) (List b)))) - (#Tag elem) - (#Form (list (#Tag "Tag") (#Text elem))) - - (#Ident elem) - (#Form (list (#Tag "Ident") (#Text elem))) - - (#Form (#Cons (#Ident "~") (#Cons unquoted #Nil))) - unquoted - - (#Tuple elems) - (#Form (list (#Tag "Tuple") (untemplate-list untemplate elems))) - - (#Form elems) - (#Form (list (#Tag "Form") (untemplate-list untemplate elems))) - )) - - - ## I/O - (def (print x) - (jvm:invokevirtual java.io.PrintStream "print" [Object] - (jvm:getstatic System out) [x])) - - (def (println x) - (jvm:invokevirtual java.io.PrintStream "println" [Object] - (jvm:getstatic System out) [x])) - - (annotate ' Macro) - (def (' form) - (case form - (#Cons token #Nil) - (untemplate token))) - - (def (+ x y) - (jvm:iadd x y)) - - (def inc (+ 1)) - - (def length (fold (lambda' l (lambda' x (inc l))) 0)) - - (def (rem dividend divisor) - (jvm:irem dividend divisor)) - - (def (= x y) - (jvm:invokevirtual Object "equals" [Object] - x [y])) - - (def (pairs list) - (case list - (#Cons x (#Cons y list*)) - (#Cons [x y] (pairs list*)) - - _ - #Nil)) - - (def (show x) - (jvm:invokevirtual Object "toString" [] - x [])) - - (def (concat t1 t2) - (jvm:invokevirtual String "concat" [String] - t1 [t2])) - - (def (range from to) - (if (= from to) - #Nil - (#Cons from (range (inc from) to)))) - - (def (text->list text) - (let' length (jvm:invokevirtual String "length" [] - text []) - (map (lambda' idx - (jvm:invokevirtual String "charAt" [int] - text [idx])) - (range 0 length)))) - - (def (enumerate list) - (case (fold (lambda' state - (lambda' x - (case state - [idx list'] - [(inc idx) (#Cons [idx x] list')]))) - [0 #Nil] - list) - [_ list'] - (reverse list'))) - - (def list-map #Nil) - - (def (put key val map) - (case map - #Nil - (#Cons [key val] map) - - (#Cons [?key ?val] map') - (if (= key ?key) - (#Cons [?key val] map') - (#Cons [?key ?val] (put key val map'))))) - - (def (get key map) - (case map - #Nil - #None - - (#Cons [?key ?val] map') - (if (= key ?key) - (#Some ?val) - (get key map')))) - - (def (show-kv kv) - (case kv - [?key ?val] - (fold concat "" (list "#" ?key " " (show ?val))))) - - (def (interpose elem list) - (case list - (#Cons x (#Cons y list')) - (#Cons x (#Cons elem (#Cons y list'))) - - _ - list)) - - (def (show-list xs) - (case xs - #Nil - "#Nil" - (#Cons x xs') - (fold concat "" (list "(#Cons " (show x) " " (show-list xs') ")")))) - - )# +(defsig (Collection c) +(: add (All [x] (-> x (c x) (c x)))) +(: length (All [x] (-> (c x) Int)))) + +(defclass (Stack s) +(: push (All [x] (-> x (s x) (s x)))) +(: pop (All [x] (-> (s x) (s x)))) +(: peek (All [x] (-> (s x) (Maybe x))))) + +(deftype (BinaryOp t) +(-> t t t)) + +(defclass (Number n) +(: + (BinaryOp n)) +(: - (BinaryOp n)) +(: * (BinaryOp n)) +(: / (BinaryOp n))) + +(def (flip f) +(lambda [x y] +(f y x))) + +(def (concat' xss) +(case (reverse xss) +#Nil +#Nil + +(#Cons xs xss') +(fold (flip ++) xs xss'))) + +n + n*m + +(with [AddInt] +(+ 10 20)) + +(:: AddInt (+ 10 20)) == ((get@ AddInt #=) 10 20) + +(defimpl (Stack List) +(def (push x xs) +(#Cons x xs)) + +(def (pop xs) +(case xs +#Nil #Nil +(#Cons _ xs') xs')) + +(def (peek xs) +(case xs +#Nil #None +(#Cons x _) (#Some x)))) + +(defsig (Functor f) +(: map (All [a b] (-> (-> a b) (f a) (f b))))) + +(def (Functor f) +{#map (All [a b] (-> (-> a b) (f a) (f b)))}) + +(defimpl ListFunctor (Functor List) +(def (map func fa) +(case fa +#Nil +#Nil + +(list a fa') +(list (func a) (map func fa'))))) + +(implicit ListFunctor +(map inc (list 1 2 3))) + +(defsig (=> [(Functor m)] +(Monad m)) +(: return (All [x] (-> x (m x)))) +(: bind (All [a b] (-> (m a) (-> a (m b)) (m b))))) + + + +(#User {#name Text #age Int}) +(deftype User {#name Text #age Int}) +(deftype User (& (#name Text) +(#age Int))) +(deftype User (All [r] +(& (#name Text) +(#age Int) +++ r))) +(def User (#Record (list ["name" Text] ["age" Int]))) + +(let [thunk (... (+ 5 6))] +(! thunk)) + +(Thunk Int) + + +(deftype Int&Bool [Int Bool]) + +(deftype (List a) +(| #Nil +(#Cons a (List a)))) + +(defclass (Equal a) +(: = (-> a a Bool))) +== +(deftype (Equal a) +{#= (-> a a Bool)}) + +(def Equals +(All [a] {#= (-> a a Bool)})) + +(defimpl EqualBool [(Equal Bool)] +(def (= x y) +(if x +y +(not y)))) + +(def ... {#= (lambda [x y] (if x +y +(not y)))}) + +(def Class (All [I] +(Exists [S] (& (#state S) +(#methods (I S)))))) + +(definterface Vector +(: translate (BinaryOp Vector))) + +(def Vector (Some [Vector] +(& (#translate (BinaryOp v))))) + +(defclass Vector2D +{#x Real, #y Real} +(def (new-Vector2D x y) +{#x x, #y y}) +Vector +(def (translate self offset) +(-> self +(update@ #x + (get@ offset #x)) +(update@ #y + (get@ offset #y))))) + +(def Vector2D +{#translate (: (lambda [self offset] +(-> self +(update@ #x +real (get@ offset #x)) +(update@ #y +real (get@ offset #y)))) +(BinaryOp {#x Real, #y Real}))}) + +(: new-Vector2D (-> Real Real [{#x Real, #y Real} (@class Vector2D)])) +(def (new-Vector2D x y) +[{#x x, #y y} Vector2D]) + +(defsig (Vector v) +(: translate (BinaryOp v)) +(: scale (BinaryOp v))) + +(def Vector (All Vector [v] +(& (#translate (BinaryOp v)) +(#scale (BinaryOp v))))) + +(defstruct Vector2D (Vector [Real Real]) +(def (translate [x1 y1] [x2 y2]) +[(+ x1 x2) (+ y1 y2)]) +(def (scale [x1 y1] [x2 y2]) +[(* x1 x2) (* y1 y2)])) + +(def Vector2D (: {#translate (lambda [[x1 y1] [x2 y2]] +[(+real x1 x2) (+real y1 y2)]) +#scale (lambda [[x1 y1] [x2 y2]] +[(*real x1 x2) (*real y1 y2)])} +(Vector [Real Real]))) + +(deftype (Stream a) +(| (#Cons a (Thunk (Stream a))))) + +(: iterate (All [a] (-> (-> a a) a (Stream a)))) +(def (iterate f init) +(list init (... (iterate f (f init))))) + +(def (take n stream) +(if (<= n 0) +#Nil +(case stream +(#Cons x stream') +(#Cons x (take (dec n) stream'))))) + +(deftype (Stream a) +(All [b] (-> (-> a (Stream a b) b) b))) + +(: iterate (All [a] (-> (-> a a) a (Stream a)))) +(def (iterate f init) +(lambda [k] +(k init (iterate f (f init))))) + +(def (repeat x) +(lambda [k] (k x (repeat x)))) + +(def (take n stream) +(if (<= n 0) +#Nil +(stream (lambda [x stream'] +(#Cons x (take (dec n) stream')))))) + +(defsig (Comonad w) +(: extract (All [a] (-> (w a) a))) +(: extend (All [a b] (-> (w a) (-> (w a) b) (w b))))) + +(defstruct Stream (Comonad w) +(def (extract stream) +(stream (lambda [x _] x))) +(def (extend w f) +...)) + +(: fibonacci (Stream Int)) +(def fibonacci ((lambda fibonacci [a b] +(lambda [k] (k a (fibonacci b (+ a b))))) +0 1)) + +(gen fibonacci [a 0 b 1] +(yield a (fibonacci b (+ a b)))) + +(defgen fibonacci [a 0 b 1] +(yield a (fibonacci b (+ a b)))) + +(gen fibonacci [a 0 b 1] +(yield a [b (+ a b)])) + +## The dual of do-notation should be be-notation + +(deftype (Stream a) +(| (#Cons a (Thunk (Stream a))))) + +(defstruct (Functor Stream) +(def (map f s) +(lambda [k] +(stream (lambda [x stream'] +(f s)))))) + +(deftype (Tape a) +(| (#Index (Thunk (Stream a)) a (Thunk (Stream a))))) + +(deftype (Area a) +(| (#Cursor (Tape a) (Surreal a)))) + +(def (ints offset n) +(#Index (... (iterate (lambda [n'] (- n' offset)) n)) +n +(... (iterate (+ offset) n)))) + +(def (reals offset x) +(#Cursor (ints offset x) +(reals (/ offset 10) 0))) +)# + +#( +(deftype (Session i o s) + (All [s' r] + (-> (-> i s' r) + (-> o s [i s']) + r)) + + (All [s' s''] (-> (-> c s' [p s'']) + (-> [] s [c s']) (Session c p s) + [p s''])) + (All [] (-> (-> c s p) + (-> p []))) + (All [r] (-> c (Session r p s) p))) + +(Session Int [] (Session Int (Session [] Int ))) + +(bind (session' []) + (lambda [x session'] + (bind (session' []) + (lambda [y session''] + (session'' (+ x y)))))) + +(defstruct SessionMonad + (Monad Session) + (def (return v) + (lambda [k session] + (k v session))) + (def (bind step m-value) + (lambda [k session] + (let [[v session'] (m-value [] session)] + (k (step v) session'))))) + +## Not really "do"; but oh, well... + +(deftype + (| #Nil)) + +(deftype (HList h t) + (| (#Cons h t))) + +(deftype (Session c p s) + (All [r] (-> c (-> p s r) r))) + +(deftype (Session c p s) + (-> (-> p s c) c)) + +(deftype (? r s) + (Session r [] s)) + +(deftype (! w s) + (Session [] w s)) + +(deftype #rec + (Session [] [] )) + +(def << + (lambda [k session] + (k [] session))) + +(def (>> val) + (lambda [k session] + (session val k))) + +(<$> << (>> 5)) + +(def (<$> consumer producer) + (producer [] consumer)) + +(HList Int (HList Int )) + +(<.> (? Int) (? Int) (! Int) ) +(def fn-session + (do [x << + y <<] + (>> (+ x y)))) + +(<.> (! Int) (! Int) (? Int) ) +(def call-session + (do [_ (>> 5) + _ (>> 10)] + <<)) + +(<$> fn-session call-session) + +(def << + (lambda [chan] + (chan (lambda [])))) + +(def (>> value) + (lambda [chan] + (chan value))) +)# -- cgit v1.2.3