From cc5e279701b2805987a2ed6937e30dbc54328639 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Thu, 12 Sep 2024 16:46:49 -0700 Subject: [PATCH 01/17] More library additions --- library/classes.lisp | 15 +++++++-- library/functions.lisp | 11 +++++-- library/iterator.lisp | 11 +++++++ library/list.lisp | 19 +++++++++-- library/ord-map.lisp | 71 ++++++++++++++++++++++++++++++++++++++++-- library/ord-tree.lisp | 52 ++++++++++++++++++++++++++----- library/string.lisp | 6 ++-- 7 files changed, 166 insertions(+), 19 deletions(-) diff --git a/library/classes.lisp b/library/classes.lisp index 7b3e2029d..2d36faada 100644 --- a/library/classes.lisp +++ b/library/classes.lisp @@ -20,10 +20,10 @@ #:Functor #:map #:Applicative #:pure #:liftA2 #:Monad #:>>= - #:>> + #:>> #:join #:MonadFail #:fail #:Alternative #:alt #:empty - #:Foldable #:fold #:foldr #:mconcat + #:Foldable #:fold #:foldr #:mconcat #:mconcatmap #:Traversable #:traverse #:Bifunctor #:bimap #:map-fst #:map-snd #:sequence @@ -211,8 +211,14 @@ (declare >> (Monad :m => (:m :a) -> (:m :b) -> (:m :b))) (define (>> a b) + "Equivalent to `(>>= a (fn (_) b))`." (>>= a (fn (_) b))) + (declare join ((Monad :m) => :m (:m :a) -> :m :a)) + (define (join m) + "Equivalent to `(>>= m id)`." + (>>= m (fn (x) x))) + (define-class (Monad :m => MonadFail :m) (fail (String -> :m :a))) @@ -231,6 +237,11 @@ "Fold a container of monoids into a single element." (fold <> mempty)) + (declare mconcatmap ((Foldable :f) (Monoid :a) => (:b -> :a) -> :f :b -> :a)) + (define (mconcatmap f) + "Map a container to a container of monoids, and then fold that container into a single element." + (fold (fn (a b) (<> a (f b))) mempty)) + (define-class (Traversable :t) (traverse (Applicative :f => (:a -> :f :b) -> :t :a -> :f (:t :b)))) diff --git a/library/functions.lisp b/library/functions.lisp index ec507983c..f697e68dc 100644 --- a/library/functions.lisp +++ b/library/functions.lisp @@ -160,7 +160,14 @@ ;; (define-instance (Functor (Arrow :a)) - (define map compose))) + (define map compose)) + + (define-instance (Applicative (Arrow :a)) + (define (pure x) (fn (_) x)) + (define (liftA2 f g h) (fn (x) (f (g x) (h x))))) + + (define-instance (Monad (Arrow :a)) + (define (>>= f g) (fn (x) (g (f x) x))))) ;;; ;;; Bracket pattern @@ -171,7 +178,7 @@ (cl:let ((output (cl:gensym "OUTPUT"))) `(cl:let (,output) (cl:unwind-protect (cl:setq ,output (call-coalton-function ,thunk ,obj)) - (call-coalton-function ,exit ,obj)) + (call-coalton-function ,exit ,obj)) ,output))) (coalton-toplevel diff --git a/library/iterator.lisp b/library/iterator.lisp index 458f2a884..e15b86728 100644 --- a/library/iterator.lisp +++ b/library/iterator.lisp @@ -42,6 +42,8 @@ #:take! #:flatten! #:flat-map! + #:mconcat! + #:mconcatmap! #:chain! #:remove-duplicates! ; defined in library/hashtable.lisp #:pair-with! @@ -423,6 +425,15 @@ interleaving. (interleave empty ITER) is equivalent to (id ITER)." "Flatten! wrapped around map." (flatten! (map func iter))) + (declare mconcat! ((Monoid :a) => (Iterator :a) -> :a)) + (define mconcat! + "Fold an iterator of monoids into a single element." + (fold! <> mempty)) + + (declare mconcatmap! ((Monoid :a) => (:b -> :a) -> (Iterator :b) -> :a)) + (define (mconcatmap! f) + "Map an iterator to an iterator of monoids, and then fold that iterator into a single element." + (compose (fold! <> mempty) (map f))) (declare pair-with! ((:key -> :value) -> Iterator :key -> Iterator (Tuple :key :value))) (define (pair-with! func keys) diff --git a/library/list.lisp b/library/list.lisp index d472cfd66..1d10a9b4c 100644 --- a/library/list.lisp +++ b/library/list.lisp @@ -43,8 +43,8 @@ #:lookup #:remove-duplicates #:remove-if - #:remove - #:difference + #:remove #:without + #:difference #:sdifference #:zipWith #:zipWith3 #:zipWith4 @@ -390,10 +390,23 @@ "Return a new list with the first element equal to `x` removed." (remove-if (== x) ys)) + (declare without (Eq :a => :a -> (List :a) -> (List :a))) + (define (without x) + "Return a new list without all elements equal to `x` removed" + (filter (/= x))) + (declare difference (Eq :a => ((List :a) -> (List :a) -> (List :a)))) (define (difference xs ys) "Returns a new list with the first occurence of each element in `ys` removed from `xs`." - (fold (fn (a b) (remove b a)) xs ys)) + (fold (flip remove) xs ys)) + + (declare sdifference (Eq :a => (List :a) -> (List :a) -> (List :a))) + (define (sdifference xs ys) + "Symmetric difference. + +Returns a new list with only those elements of `xs` and `ys` which are not `==' to any elements in the other." + (append (difference xs ys) + (difference ys xs))) (declare zipWith ((:a -> :b -> :c) -> (List :a) -> (List :b) -> (List :c))) (define (zipWith f xs ys) diff --git a/library/ord-map.lisp b/library/ord-map.lisp index b81f7034f..c8bf7e9c8 100644 --- a/library/ord-map.lisp +++ b/library/ord-map.lisp @@ -12,18 +12,19 @@ (:export #:Map #:empty - #:lookup + #:lookup #:contains? #:insert #:replace #:replace-or-insert #:insert-or-replace - #:remove + #:remove #:without #:keys #:values #:entries #:collect! #:collect #:update - #:merge)) + #:merge #:union #:intersection #:difference #:sdifference + #:zip #:zip-with-default)) (in-package :coalton-library/ord-map) @@ -78,6 +79,13 @@ (match mp ((%Map tre) (coalton-library/classes:map value (tree:lookup tre (JustKey k)))))) + (declare contains? ((Ord :key) => :key -> (Map :key :value) -> Boolean)) + (define (contains? k mp) + "Does `mp` contain a key `==' to `k`?" + (match (lookup mp k) + ((Some _) True) + ((None) False))) + (declare insert ((Ord :key) => ((Map :key :value) -> :key -> :value -> (Optional (Map :key :value))))) (define (insert mp k v) "Associate K with V in MP. If MP already contains a mapping for K, return None." @@ -124,6 +132,11 @@ Like `replace-or-insert', but prioritizing insertion as a use case." (match mp ((%Map tre) (tree:remove tre (JustKey k)))))) + (declare without ((Ord :key) => :key -> (Map :key :value) -> (Map :key :value))) + (define (without k mp) + "If `mp` contains a mapping associated with a key `==' to `k`, construct a new Map without that mapping. Return `mp` if it contains no such mapping." + (with-default mp (remove mp k))) + (declare entries ((Map :key :value) -> (iter:Iterator (Tuple :key :value)))) (define (entries mp) "Iterate over the (key value) pairs in MP, sorted by the keys in least-to-greatest order." @@ -211,9 +224,61 @@ operation, and therefore Map cannot implement Monoid." (let (%Map b) = b) (%Map (tree:merge a b))) + (declare union (Ord :key => Map :key :value -> Map :key :value -> Map :key :value)) + (define union + "Same as `merge`." + merge) + + (declare intersection (Ord :key => Map :key :value -> Map :key :value -> Map :key :value)) + (define (intersection a b) + "Construct a Map containing only those mappings from `b` that contain a key `==' to at least one key in `a`." + (let (%Map a) = a) + (let (%Map b) = b) + (%Map (tree:intersection a b))) + + (declare difference (Ord :key => Map :key :value -> Map :key :value -> Map :key :value)) + (define (difference a b) + "Construct a Map containing only those mappings from `b` which contain a key not `==' to any key in `a`." + (let (%Map a) = a) + (let (%Map b) = b) + (%Map (tree:difference a b))) + + (declare sdifference (Ord :key => Map :key :value -> Map :key :value -> Map :key :value)) + (define (sdifference a b) + "Symmetric difference. + +Construct a Map containing only those mapping sof `a` and `b` which do not associate keys `==' keys in the other." + (let (%Map a) = a) + (let (%Map b) = b) + (%Map (tree:sdifference a b))) + + (declare zip (Ord :key => Map :key :value1 -> Map :key :value2 -> Map :key (Tuple :value1 :value2))) + (define (zip a b) + "Construct a Map associating only those keys included in both `a` and `b` to the Tuple containing their respective values." + (fold (fn (mp k) + (insert-or-replace mp k (Tuple (unwrap (lookup a k)) + (unwrap (lookup b k))))) + Empty + (tree:intersection (tree:collect! (keys a)) + (tree:collect! (keys b))))) + + (declare zip-with-default ((Ord :key) (Default :value1) (Default :value2) + => Map :key :value1 -> Map :key :value2 -> Map :key (Tuple :value1 :value2))) + (define (zip-with-default a b) + "Construct a Map associating all keys `a` and `b` to the Tuple containing their respective values, using the default value of the respectie types where a key is not associated." + (fold (fn (mp k) + (insert-or-replace mp k (Tuple (defaulting-unwrap (lookup a k)) + (defaulting-unwrap (lookup b k))))) + Empty + (tree:intersection (tree:collect! (keys a)) + (tree:collect! (keys b))))) + (define-instance (Ord :key => Semigroup (Map :key :value)) (define <> merge)) + (define-instance (Ord :key => (Monoid (Map :key :value))) + (define mempty Empty)) + (define-instance (Functor (Map :key)) (define (coalton-library/classes:map func mp) (let (%Map tre) = mp) diff --git a/library/ord-tree.lisp b/library/ord-tree.lisp index 7530ef633..5cb9360c2 100644 --- a/library/ord-tree.lisp +++ b/library/ord-tree.lisp @@ -11,16 +11,16 @@ (:shadow #:empty) (:export #:Tree #:Empty - #:lookup + #:lookup #:contains? #:insert #:replace #:replace-or-insert #:insert-or-replace - #:remove + #:remove #:without #:increasing-order #:decreasing-order #:collect! - #:merge + #:merge #:union #:intersection #:difference #:sdifference #:make)) (in-package :coalton-library/ord-tree) @@ -137,7 +137,14 @@ ((GT) (lookup right needle)))) ((DoubleBlackEmpty) (error "Found double-black node outside of removal process")))) - ;;; inserting into and replacing elements of trees + (declare contains? ((Ord :elt) => :elt -> (Tree :elt) -> Boolean)) + (define (contains? elt tre) + "Does `tre` containan element `=='`to `elt`." + (match (lookup tre elt) + ((None) False) + ((Some _) True))) + +;;; inserting into and replacing elements of trees (declare balance (Color -> (Tree :elt) -> :elt -> (Tree :elt) -> (Tree :elt))) (define (balance clr left elt right) @@ -357,6 +364,11 @@ Like `replace-or-insert`, but prioritizing insertion as a use case." (map as-black (remove-without-as-black tre elt))) + (declare without ((Ord :elt) => :elt -> (Tree :elt) -> (Tree :elt))) + (define (without elt tre) + "If `tre` contains an element `==' to `elt`, construct a new Tree without that element. Return `tre` if it contains no such element." + (with-default tre (remove tre elt))) + ;; matt might calls this operation `del' (declare remove-without-as-black ((Ord :elt) => ((Tree :elt) -> :elt -> (Optional (Tree :elt))))) (define (remove-without-as-black tre elt) @@ -506,9 +518,35 @@ If ITER contains duplicates, later elements will overwrite earlier elements." If A and B contain elements A' and B' respectively where (== A' B'), the result will contain either A' or B'. Which one is chosen for the result is undefined." - (iter:fold! insert-or-replace - a - (increasing-order b))) + (fold insert-or-replace a b)) + + (declare union (Ord :elt => Tree :elt -> Tree :elt -> Tree :elt)) + (define union + "Same as `merge`." + merge) + + (declare intersection (Ord :elt => Tree :elt -> Tree :elt -> Tree :elt)) + (define (intersection a b) + "Construct a Tree containing only those elements from `b` which are `==' to at least one element in `a`." + (fold (fn (tre elt) + (if (contains? elt tre) + (insert-or-replace tre elt) + tre)) + Empty + a)) + + (declare difference (Ord :elt => Tree :elt -> Tree :elt -> Tree :elt)) + (define (difference a b) + "Construct a Tree containing only those elements from `b` which are not `==' to any elements in `a`." + (fold (flip without) a b)) + + (declare sdifference (Ord :elt => Tree :elt -> Tree :elt -> Tree :elt)) + (define (sdifference a b) + "Symmetric difference. + +Construct a Tree containing only those elements of `a` and `b` which are not `==' to any elements in the other." + (merge (difference a b) + (difference b a))) (define-instance (Ord :elt => Semigroup (Tree :elt)) (define <> merge)) diff --git a/library/string.lisp b/library/string.lisp index e2e7fb6ca..d397ca28d 100644 --- a/library/string.lisp +++ b/library/string.lisp @@ -218,12 +218,14 @@ does not have that suffix." (define-instance (Into Single-Float String) (define (into z) (lisp String (z) - (cl:prin1-to-string z)))) + (cl:format cl:nil "~F" z) + #+ign(cl:prin1-to-string z)))) (define-instance (Into Double-Float String) (define (into z) (lisp String (z) - (cl:prin1-to-string z)))) + (cl:format cl:nil "~F" z) + #+ign(cl:prin1-to-string z)))) (define-instance (TryInto String Integer String) (define (tryInto s) From 4d64f43b2504a2a314f937e0ecd4d443eb7978de Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Thu, 12 Sep 2024 17:21:04 -0700 Subject: [PATCH 02/17] Added more additions. --- library/classes.lisp | 7 ++++- library/list.lisp | 6 +++++ library/ord-tree.lisp | 2 +- src/language-macros.lisp | 58 ++++++++++++++++++++++++++++++++++++++++ src/package.lisp | 2 ++ 5 files changed, 73 insertions(+), 2 deletions(-) diff --git a/library/classes.lisp b/library/classes.lisp index 2d36faada..15d5e9ad8 100644 --- a/library/classes.lisp +++ b/library/classes.lisp @@ -30,7 +30,7 @@ #:Into #:TryInto #:Iso - #:Unwrappable #:unwrap-or-else #:with-default #:unwrap #:expect #:as-optional + #:Unwrappable #:unwrap-or-else #:with-default #:unwrap #:unwrap-into #:expect #:as-optional #:default #:defaulting-unwrap #:default?)) (in-package #:coalton-library/classes) @@ -325,6 +325,11 @@ Typical `fail` continuations are: container)))) container)) + (declare unwrap-into ((Unwrappable (Result :c)) (TryInto :a :b :c) => :a -> :b)) + (define unwrap-into + "Same as `tryInto` followed by `unwrap`." + (fn (x) (unwrap (tryinto x)))) + (declare with-default ((Unwrappable :container) => :element -> (:container :element) diff --git a/library/list.lisp b/library/list.lisp index 1d10a9b4c..2ec417538 100644 --- a/library/list.lisp +++ b/library/list.lisp @@ -34,6 +34,7 @@ #:elemIndex #:findIndex #:range + #:enumerate #:append #:concat #:concatMap @@ -289,6 +290,11 @@ (%reverse! (inner start end Nil)) (inner end start Nil)))) + (declare enumerate ((Num :int) (Ord :int) => List :a -> List (Tuple :int :a))) + (define (enumerate xs) + "Pair successive zero-based indices with elements from `xs`." + (iter:collect! (iter:enumerate! (iter:into-iter xs)))) + (define (append-rev list result) (match list ((Nil) result) diff --git a/library/ord-tree.lisp b/library/ord-tree.lisp index 5cb9360c2..635aadf0d 100644 --- a/library/ord-tree.lisp +++ b/library/ord-tree.lisp @@ -529,7 +529,7 @@ B'. Which one is chosen for the result is undefined." (define (intersection a b) "Construct a Tree containing only those elements from `b` which are `==' to at least one element in `a`." (fold (fn (tre elt) - (if (contains? elt tre) + (if (contains? elt b) (insert-or-replace tre elt) tre)) Empty diff --git a/src/language-macros.lisp b/src/language-macros.lisp index 88e2eb446..130eb32b8 100644 --- a/src/language-macros.lisp +++ b/src/language-macros.lisp @@ -29,6 +29,64 @@ Note that this may copy the object or allocate memory." `(fn (,lexpr) (the ,type (,into ,lexpr))))))) +(cl:defmacro try-as (type cl:&optional (expr cl:nil expr-supplied-p)) + "A syntactic convenience for type casting. + + (try-as ) + +is equivalent to + + (the (Result :_ ) (tryInto )) + +and + + (try-as ) + +is equivalent to + + (fn (expr) (the (Result :_ ) (tryInto expr))). + +Note that this may copy the object or allocate memory." + + (cl:let ((try-into (cl:ignore-errors (cl:find-symbol "TRYINTO" "COALTON-LIBRARY/CLASSES"))) + (Result (cl:ignore-errors (cl:find-symbol "RESULT" "COALTON-LIBRARY/CLASSES")))) + (cl:assert try-into () "`try-as` macro does not have access to `try-into` yet.") + (cl:assert Result () "`try-as` macro does not have access to `Result` yet.") + (cl:if expr-supplied-p + `(the (,Result :_ ,type) (,try-into ,expr)) + (alexandria:with-gensyms (lexpr) + `(fn (,lexpr) + (the (,Result :_ ,type) (,try-into ,lexpr))))))) + +(cl:defmacro unwrap-as (type cl:&optional (expr cl:nil expr-supplied-p)) + "A syntactic convenience for type casting. + + (unwrap-as ) + +is equivalent to + + (the (uwrap (tryInto ))) + +and + + (unwrap-as ) + +is equivalent to + + (fn (expr) (the (unwrap (tryInto expr)))). + +Note that this may copy the object or allocate memory." + + (cl:let ((try-into (cl:ignore-errors (cl:find-symbol "TRYINTO" "COALTON-LIBRARY/CLASSES"))) + (unwrap (cl:ignore-errors (cl:find-symbol "UNWRAP" "COALTON-LIBRARY/CLASSES")))) + (cl:assert try-into () "`try-as` macro does not have access to `try-into` yet.") + (cl:assert unwrap () "`unwrap` macro does not have access to `unwrap` yet.") + (cl:if expr-supplied-p + `(the ,type (,unwrap (,try-into ,expr))) + (alexandria:with-gensyms (lexpr) + `(fn (,lexpr) + (the ,type (,unwrap (,try-into ,lexpr)))))))) + (cl:defmacro nest (cl:&rest items) "A syntactic convenience for function application. Transform diff --git a/src/package.lisp b/src/package.lisp index 8e88261ed..8f573af3b 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -88,6 +88,8 @@ #:or #:cond #:as + #:try-as + #:unwrap-as #:nest #:pipe #:.< From d49ba44d9b9ef915c73c9f601e7f508f6bc32e47 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Fri, 13 Sep 2024 10:39:33 -0700 Subject: [PATCH 03/17] Added mcommute? --- library/classes.lisp | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/library/classes.lisp b/library/classes.lisp index 15d5e9ad8..eeb1aa401 100644 --- a/library/classes.lisp +++ b/library/classes.lisp @@ -23,7 +23,7 @@ #:>> #:join #:MonadFail #:fail #:Alternative #:alt #:empty - #:Foldable #:fold #:foldr #:mconcat #:mconcatmap + #:Foldable #:fold #:foldr #:mconcat #:mconcatmap #:mcommute? #:Traversable #:traverse #:Bifunctor #:bimap #:map-fst #:map-snd #:sequence @@ -242,6 +242,11 @@ "Map a container to a container of monoids, and then fold that container into a single element." (fold (fn (a b) (<> a (f b))) mempty)) + (declare mcommute? ((Eq :a) (Monoid :a) => :a -> :a -> Boolean)) + (define (mcommute? a b) + "Does `a <> b` `==' `b <> a`?" + (== (<> a b) (<> b a))) + (define-class (Traversable :t) (traverse (Applicative :f => (:a -> :f :b) -> :t :a -> :f (:t :b)))) From fb938cb8fb9cc7bf0d17d34b4f4abc1589829757 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Fri, 13 Sep 2024 15:48:56 -0700 Subject: [PATCH 04/17] Added apply macro --- src/language-macros.lisp | 13 +++++++++++++ src/package.lisp | 1 + 2 files changed, 14 insertions(+) diff --git a/src/language-macros.lisp b/src/language-macros.lisp index 130eb32b8..6611f7d4f 100644 --- a/src/language-macros.lisp +++ b/src/language-macros.lisp @@ -113,6 +113,19 @@ to (cl:assert (cl:<= 2 (cl:list-length items))) `(nest ,@(cl:reverse items))) +(cl:defmacro apply (cl:&rest items) + "A syntactic convenience for function application. Transform + + (APPLY w x y z) + +to + + (fn (f) (f w x y z))." + + (alexandria:with-gensyms (f) + `(fn (,f) + (,f ,@items)))) + (cl:defmacro .< (cl:&rest items) "Right associative compose operator. Creates a new functions that will run the functions right to left when applied. This is the same as the NEST macro without supplying diff --git a/src/package.lisp b/src/package.lisp index 8f573af3b..c90866f55 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -92,6 +92,7 @@ #:unwrap-as #:nest #:pipe + #:apply #:.< #:.> #:make-list From 5edf0bf16bdcffd88ab11086ea4089162059004b Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Fri, 13 Sep 2024 15:53:03 -0700 Subject: [PATCH 05/17] Revert "Added apply macro" This reverts commit fb938cb8fb9cc7bf0d17d34b4f4abc1589829757. --- src/language-macros.lisp | 13 ------------- src/package.lisp | 1 - 2 files changed, 14 deletions(-) diff --git a/src/language-macros.lisp b/src/language-macros.lisp index 6611f7d4f..130eb32b8 100644 --- a/src/language-macros.lisp +++ b/src/language-macros.lisp @@ -113,19 +113,6 @@ to (cl:assert (cl:<= 2 (cl:list-length items))) `(nest ,@(cl:reverse items))) -(cl:defmacro apply (cl:&rest items) - "A syntactic convenience for function application. Transform - - (APPLY w x y z) - -to - - (fn (f) (f w x y z))." - - (alexandria:with-gensyms (f) - `(fn (,f) - (,f ,@items)))) - (cl:defmacro .< (cl:&rest items) "Right associative compose operator. Creates a new functions that will run the functions right to left when applied. This is the same as the NEST macro without supplying diff --git a/src/package.lisp b/src/package.lisp index c90866f55..8f573af3b 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -92,7 +92,6 @@ #:unwrap-as #:nest #:pipe - #:apply #:.< #:.> #:make-list From 063b9300735d4f0ac816e86ae01f431eddbb3c6e Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Mon, 16 Sep 2024 09:26:48 -0700 Subject: [PATCH 06/17] Fixed docstring typo. Co-authored-by: Thomas Draper --- library/ord-map.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/ord-map.lisp b/library/ord-map.lisp index c8bf7e9c8..3bed65809 100644 --- a/library/ord-map.lisp +++ b/library/ord-map.lisp @@ -247,7 +247,7 @@ operation, and therefore Map cannot implement Monoid." (define (sdifference a b) "Symmetric difference. -Construct a Map containing only those mapping sof `a` and `b` which do not associate keys `==' keys in the other." +Construct a Map containing only those mappings of `a` and `b` which do not associate keys `==' keys in the other." (let (%Map a) = a) (let (%Map b) = b) (%Map (tree:sdifference a b))) From 9739d5eb44594f21a5f1bf19c6dbbbc719fe9273 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Mon, 16 Sep 2024 09:27:00 -0700 Subject: [PATCH 07/17] Fixed docstring typo. Co-authored-by: Thomas Draper --- library/ord-tree.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/ord-tree.lisp b/library/ord-tree.lisp index 635aadf0d..24b1614fd 100644 --- a/library/ord-tree.lisp +++ b/library/ord-tree.lisp @@ -139,7 +139,7 @@ (declare contains? ((Ord :elt) => :elt -> (Tree :elt) -> Boolean)) (define (contains? elt tre) - "Does `tre` containan element `=='`to `elt`." + "Does `tre` contain an element `==` to `elt`." (match (lookup tre elt) ((None) False) ((Some _) True))) From a0840eb343214c8237444fa56e162e83ddb421ab Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Tue, 17 Sep 2024 11:26:01 -0700 Subject: [PATCH 08/17] Added filtering for ord-map and -tree. --- library/ord-map.lisp | 26 ++++++++++++++++++++++++-- library/ord-tree.lisp | 33 ++++++++++++++++++++++++++++++++- 2 files changed, 56 insertions(+), 3 deletions(-) diff --git a/library/ord-map.lisp b/library/ord-map.lisp index 3bed65809..8f9693399 100644 --- a/library/ord-map.lisp +++ b/library/ord-map.lisp @@ -24,6 +24,7 @@ #:collect #:update #:merge #:union #:intersection #:difference #:sdifference + #:filter-by-key #:filter-by-value #:filter-by-entry #:zip #:zip-with-default)) (in-package :coalton-library/ord-map) @@ -176,6 +177,9 @@ If `iter` contains duplicate keys, later values will overwrite earlier values." empty iter)) + (define-instance (Ord :key => iter:FromIterator (Map :key :value) (Tuple :key :value)) + (define iter:collect! collect!)) + (declare collect ((Ord :key) (Foldable :collection) => ((:collection (Tuple :key :value)) -> (Map :key :value)))) (define (collect coll) "Construct a `Map` containing all the `(key value)` pairs in `coll`. @@ -186,8 +190,8 @@ If `coll` contains duplicate keys, later values will overwrite earlier values." empty coll)) - (define-instance (Ord :key => iter:FromIterator (Map :key :value) (Tuple :key :value)) - (define iter:collect! collect!)) + (define-instance ((Ord :key) (Foldable :collection) => (Into (:collection (Tuple :key :value)) (Map :key :value))) + (define into collect)) (declare update ((Ord :key) => (:value -> :value) -> (Map :key :value) -> :key -> (Optional (Map :key :value)))) (define (update func mp key) @@ -252,6 +256,24 @@ Construct a Map containing only those mappings of `a` and `b` which do not assoc (let (%Map b) = b) (%Map (tree:sdifference a b))) + (declare filter-by-key (Ord :key => (:key -> Boolean) -> Map :key :value -> Map :key :value)) + (define (filter-by-key keep? mp) + "Construct a Map containing only those entries of `mp` which contain keys which satisfy `keep?`." + (let (%Map mp) = mp) + (%Map (tree:filter (compose keep? key) mp))) + + (declare filter-by-value (Ord :key => (:value -> Boolean) -> Map :key :value -> Map :key :value)) + (define (filter-by-value keep? mp) + "Construct a Map containing only those entries of `mp` which contain values which satisfy `keep?`." + (let (%Map mp) = mp) + (%Map (tree:filter (compose keep? value) mp))) + + (declare filter-by-entry (Ord :key => ((Tuple :key :value) -> Boolean) -> Map :key :value -> Map :key :value)) + (define (filter-by-entry keep? mp) + "Construct a Map containing only those entries of `mp` which satisfy `keep?`." + (let (%Map mp) = mp) + (%Map (tree:filter (compose keep? into) mp))) + (declare zip (Ord :key => Map :key :value1 -> Map :key :value2 -> Map :key (Tuple :value1 :value2))) (define (zip a b) "Construct a Map associating only those keys included in both `a` and `b` to the Tuple containing their respective values." diff --git a/library/ord-tree.lisp b/library/ord-tree.lisp index 24b1614fd..6395d7232 100644 --- a/library/ord-tree.lisp +++ b/library/ord-tree.lisp @@ -19,8 +19,10 @@ #:remove #:without #:increasing-order #:decreasing-order - #:collect! + #:collect! #:collect + #:filter-collect! #:filter-collect #:merge #:union #:intersection #:difference #:sdifference + #:filter #:make)) (in-package :coalton-library/ord-tree) @@ -509,9 +511,33 @@ The result tree may be in an intermediate state with a double-black node." If ITER contains duplicates, later elements will overwrite earlier elements." (iter:fold! insert-or-replace Empty iter)) + (declare filter-collect! ((Ord :elt) => (:elt -> Boolean) -> (iter:Iterator :elt) -> (Tree :elt))) + (define (filter-collect! keep? iter) + "Construct a Tree containing only those elements of `iter` which satisfy `keep?`. + +If ITER contains duplicates, later elements will overwrite earlier elements." + (collect! (iter:filter! keep? iter))) + (define-instance (Ord :elt => iter:FromIterator (Tree :elt) :elt) (define iter:collect! collect!)) + (declare collect ((Ord :elt) (Foldable :collection) => (:collection :elt)-> (Tree :elt))) + (define (collect coll) + "Construct a Tree containing all the elements of COLL. + +If COLL contains duplicates, later elements will overwrite earlier elements." + (fold insert-or-replace Empty coll)) + + (declare filter-collect ((Ord :elt) (Foldable :collection) => (:elt -> Boolean) -> (:collection :elt)-> (Tree :elt))) + (define (filter-collect keep? coll) + "Construct a Tree containing only those elements of `coll` which satisfy `keep?`. + +If COLL contains duplicates, later elements will overwrite earlier elements." + (fold (fn (tre elt) (if (keep? elt) (insert-or-replace tre elt) tre)) Empty coll)) + + (define-instance ((Ord :elt) (Foldable :collection) => (Into (:collection :elt) (Tree :elt))) + (define into collect)) + (declare merge (Ord :elt => Tree :elt -> Tree :elt -> Tree :elt)) (define (merge a b) "Construct a Tree containing all the elements of both A and B. @@ -548,6 +574,11 @@ Construct a Tree containing only those elements of `a` and `b` which are not `== (merge (difference a b) (difference b a))) + (declare filter (Ord :elt => (:elt -> Boolean) -> Tree :elt -> Tree :elt)) + (define (filter keep? tre) + "Construct a Tree containing only those elements of `tre` which satisfy `keep?`." + (fold (fn (new-tre elt) (if (keep? elt) (insert-or-replace new-tre elt) new-tre)) Empty tre)) + (define-instance (Ord :elt => Semigroup (Tree :elt)) (define <> merge)) From 974ba2cf8f50df00ff11cc924437a318d6713937 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Thu, 12 Sep 2024 16:46:49 -0700 Subject: [PATCH 09/17] More library additions --- library/classes.lisp | 15 +++++++-- library/functions.lisp | 11 +++++-- library/iterator.lisp | 11 +++++++ library/list.lisp | 19 +++++++++-- library/ord-map.lisp | 71 ++++++++++++++++++++++++++++++++++++++++-- library/ord-tree.lisp | 52 ++++++++++++++++++++++++++----- library/string.lisp | 6 ++-- 7 files changed, 166 insertions(+), 19 deletions(-) diff --git a/library/classes.lisp b/library/classes.lisp index 7b3e2029d..2d36faada 100644 --- a/library/classes.lisp +++ b/library/classes.lisp @@ -20,10 +20,10 @@ #:Functor #:map #:Applicative #:pure #:liftA2 #:Monad #:>>= - #:>> + #:>> #:join #:MonadFail #:fail #:Alternative #:alt #:empty - #:Foldable #:fold #:foldr #:mconcat + #:Foldable #:fold #:foldr #:mconcat #:mconcatmap #:Traversable #:traverse #:Bifunctor #:bimap #:map-fst #:map-snd #:sequence @@ -211,8 +211,14 @@ (declare >> (Monad :m => (:m :a) -> (:m :b) -> (:m :b))) (define (>> a b) + "Equivalent to `(>>= a (fn (_) b))`." (>>= a (fn (_) b))) + (declare join ((Monad :m) => :m (:m :a) -> :m :a)) + (define (join m) + "Equivalent to `(>>= m id)`." + (>>= m (fn (x) x))) + (define-class (Monad :m => MonadFail :m) (fail (String -> :m :a))) @@ -231,6 +237,11 @@ "Fold a container of monoids into a single element." (fold <> mempty)) + (declare mconcatmap ((Foldable :f) (Monoid :a) => (:b -> :a) -> :f :b -> :a)) + (define (mconcatmap f) + "Map a container to a container of monoids, and then fold that container into a single element." + (fold (fn (a b) (<> a (f b))) mempty)) + (define-class (Traversable :t) (traverse (Applicative :f => (:a -> :f :b) -> :t :a -> :f (:t :b)))) diff --git a/library/functions.lisp b/library/functions.lisp index ec507983c..f697e68dc 100644 --- a/library/functions.lisp +++ b/library/functions.lisp @@ -160,7 +160,14 @@ ;; (define-instance (Functor (Arrow :a)) - (define map compose))) + (define map compose)) + + (define-instance (Applicative (Arrow :a)) + (define (pure x) (fn (_) x)) + (define (liftA2 f g h) (fn (x) (f (g x) (h x))))) + + (define-instance (Monad (Arrow :a)) + (define (>>= f g) (fn (x) (g (f x) x))))) ;;; ;;; Bracket pattern @@ -171,7 +178,7 @@ (cl:let ((output (cl:gensym "OUTPUT"))) `(cl:let (,output) (cl:unwind-protect (cl:setq ,output (call-coalton-function ,thunk ,obj)) - (call-coalton-function ,exit ,obj)) + (call-coalton-function ,exit ,obj)) ,output))) (coalton-toplevel diff --git a/library/iterator.lisp b/library/iterator.lisp index 458f2a884..e15b86728 100644 --- a/library/iterator.lisp +++ b/library/iterator.lisp @@ -42,6 +42,8 @@ #:take! #:flatten! #:flat-map! + #:mconcat! + #:mconcatmap! #:chain! #:remove-duplicates! ; defined in library/hashtable.lisp #:pair-with! @@ -423,6 +425,15 @@ interleaving. (interleave empty ITER) is equivalent to (id ITER)." "Flatten! wrapped around map." (flatten! (map func iter))) + (declare mconcat! ((Monoid :a) => (Iterator :a) -> :a)) + (define mconcat! + "Fold an iterator of monoids into a single element." + (fold! <> mempty)) + + (declare mconcatmap! ((Monoid :a) => (:b -> :a) -> (Iterator :b) -> :a)) + (define (mconcatmap! f) + "Map an iterator to an iterator of monoids, and then fold that iterator into a single element." + (compose (fold! <> mempty) (map f))) (declare pair-with! ((:key -> :value) -> Iterator :key -> Iterator (Tuple :key :value))) (define (pair-with! func keys) diff --git a/library/list.lisp b/library/list.lisp index d472cfd66..1d10a9b4c 100644 --- a/library/list.lisp +++ b/library/list.lisp @@ -43,8 +43,8 @@ #:lookup #:remove-duplicates #:remove-if - #:remove - #:difference + #:remove #:without + #:difference #:sdifference #:zipWith #:zipWith3 #:zipWith4 @@ -390,10 +390,23 @@ "Return a new list with the first element equal to `x` removed." (remove-if (== x) ys)) + (declare without (Eq :a => :a -> (List :a) -> (List :a))) + (define (without x) + "Return a new list without all elements equal to `x` removed" + (filter (/= x))) + (declare difference (Eq :a => ((List :a) -> (List :a) -> (List :a)))) (define (difference xs ys) "Returns a new list with the first occurence of each element in `ys` removed from `xs`." - (fold (fn (a b) (remove b a)) xs ys)) + (fold (flip remove) xs ys)) + + (declare sdifference (Eq :a => (List :a) -> (List :a) -> (List :a))) + (define (sdifference xs ys) + "Symmetric difference. + +Returns a new list with only those elements of `xs` and `ys` which are not `==' to any elements in the other." + (append (difference xs ys) + (difference ys xs))) (declare zipWith ((:a -> :b -> :c) -> (List :a) -> (List :b) -> (List :c))) (define (zipWith f xs ys) diff --git a/library/ord-map.lisp b/library/ord-map.lisp index b81f7034f..c8bf7e9c8 100644 --- a/library/ord-map.lisp +++ b/library/ord-map.lisp @@ -12,18 +12,19 @@ (:export #:Map #:empty - #:lookup + #:lookup #:contains? #:insert #:replace #:replace-or-insert #:insert-or-replace - #:remove + #:remove #:without #:keys #:values #:entries #:collect! #:collect #:update - #:merge)) + #:merge #:union #:intersection #:difference #:sdifference + #:zip #:zip-with-default)) (in-package :coalton-library/ord-map) @@ -78,6 +79,13 @@ (match mp ((%Map tre) (coalton-library/classes:map value (tree:lookup tre (JustKey k)))))) + (declare contains? ((Ord :key) => :key -> (Map :key :value) -> Boolean)) + (define (contains? k mp) + "Does `mp` contain a key `==' to `k`?" + (match (lookup mp k) + ((Some _) True) + ((None) False))) + (declare insert ((Ord :key) => ((Map :key :value) -> :key -> :value -> (Optional (Map :key :value))))) (define (insert mp k v) "Associate K with V in MP. If MP already contains a mapping for K, return None." @@ -124,6 +132,11 @@ Like `replace-or-insert', but prioritizing insertion as a use case." (match mp ((%Map tre) (tree:remove tre (JustKey k)))))) + (declare without ((Ord :key) => :key -> (Map :key :value) -> (Map :key :value))) + (define (without k mp) + "If `mp` contains a mapping associated with a key `==' to `k`, construct a new Map without that mapping. Return `mp` if it contains no such mapping." + (with-default mp (remove mp k))) + (declare entries ((Map :key :value) -> (iter:Iterator (Tuple :key :value)))) (define (entries mp) "Iterate over the (key value) pairs in MP, sorted by the keys in least-to-greatest order." @@ -211,9 +224,61 @@ operation, and therefore Map cannot implement Monoid." (let (%Map b) = b) (%Map (tree:merge a b))) + (declare union (Ord :key => Map :key :value -> Map :key :value -> Map :key :value)) + (define union + "Same as `merge`." + merge) + + (declare intersection (Ord :key => Map :key :value -> Map :key :value -> Map :key :value)) + (define (intersection a b) + "Construct a Map containing only those mappings from `b` that contain a key `==' to at least one key in `a`." + (let (%Map a) = a) + (let (%Map b) = b) + (%Map (tree:intersection a b))) + + (declare difference (Ord :key => Map :key :value -> Map :key :value -> Map :key :value)) + (define (difference a b) + "Construct a Map containing only those mappings from `b` which contain a key not `==' to any key in `a`." + (let (%Map a) = a) + (let (%Map b) = b) + (%Map (tree:difference a b))) + + (declare sdifference (Ord :key => Map :key :value -> Map :key :value -> Map :key :value)) + (define (sdifference a b) + "Symmetric difference. + +Construct a Map containing only those mapping sof `a` and `b` which do not associate keys `==' keys in the other." + (let (%Map a) = a) + (let (%Map b) = b) + (%Map (tree:sdifference a b))) + + (declare zip (Ord :key => Map :key :value1 -> Map :key :value2 -> Map :key (Tuple :value1 :value2))) + (define (zip a b) + "Construct a Map associating only those keys included in both `a` and `b` to the Tuple containing their respective values." + (fold (fn (mp k) + (insert-or-replace mp k (Tuple (unwrap (lookup a k)) + (unwrap (lookup b k))))) + Empty + (tree:intersection (tree:collect! (keys a)) + (tree:collect! (keys b))))) + + (declare zip-with-default ((Ord :key) (Default :value1) (Default :value2) + => Map :key :value1 -> Map :key :value2 -> Map :key (Tuple :value1 :value2))) + (define (zip-with-default a b) + "Construct a Map associating all keys `a` and `b` to the Tuple containing their respective values, using the default value of the respectie types where a key is not associated." + (fold (fn (mp k) + (insert-or-replace mp k (Tuple (defaulting-unwrap (lookup a k)) + (defaulting-unwrap (lookup b k))))) + Empty + (tree:intersection (tree:collect! (keys a)) + (tree:collect! (keys b))))) + (define-instance (Ord :key => Semigroup (Map :key :value)) (define <> merge)) + (define-instance (Ord :key => (Monoid (Map :key :value))) + (define mempty Empty)) + (define-instance (Functor (Map :key)) (define (coalton-library/classes:map func mp) (let (%Map tre) = mp) diff --git a/library/ord-tree.lisp b/library/ord-tree.lisp index 7530ef633..5cb9360c2 100644 --- a/library/ord-tree.lisp +++ b/library/ord-tree.lisp @@ -11,16 +11,16 @@ (:shadow #:empty) (:export #:Tree #:Empty - #:lookup + #:lookup #:contains? #:insert #:replace #:replace-or-insert #:insert-or-replace - #:remove + #:remove #:without #:increasing-order #:decreasing-order #:collect! - #:merge + #:merge #:union #:intersection #:difference #:sdifference #:make)) (in-package :coalton-library/ord-tree) @@ -137,7 +137,14 @@ ((GT) (lookup right needle)))) ((DoubleBlackEmpty) (error "Found double-black node outside of removal process")))) - ;;; inserting into and replacing elements of trees + (declare contains? ((Ord :elt) => :elt -> (Tree :elt) -> Boolean)) + (define (contains? elt tre) + "Does `tre` containan element `=='`to `elt`." + (match (lookup tre elt) + ((None) False) + ((Some _) True))) + +;;; inserting into and replacing elements of trees (declare balance (Color -> (Tree :elt) -> :elt -> (Tree :elt) -> (Tree :elt))) (define (balance clr left elt right) @@ -357,6 +364,11 @@ Like `replace-or-insert`, but prioritizing insertion as a use case." (map as-black (remove-without-as-black tre elt))) + (declare without ((Ord :elt) => :elt -> (Tree :elt) -> (Tree :elt))) + (define (without elt tre) + "If `tre` contains an element `==' to `elt`, construct a new Tree without that element. Return `tre` if it contains no such element." + (with-default tre (remove tre elt))) + ;; matt might calls this operation `del' (declare remove-without-as-black ((Ord :elt) => ((Tree :elt) -> :elt -> (Optional (Tree :elt))))) (define (remove-without-as-black tre elt) @@ -506,9 +518,35 @@ If ITER contains duplicates, later elements will overwrite earlier elements." If A and B contain elements A' and B' respectively where (== A' B'), the result will contain either A' or B'. Which one is chosen for the result is undefined." - (iter:fold! insert-or-replace - a - (increasing-order b))) + (fold insert-or-replace a b)) + + (declare union (Ord :elt => Tree :elt -> Tree :elt -> Tree :elt)) + (define union + "Same as `merge`." + merge) + + (declare intersection (Ord :elt => Tree :elt -> Tree :elt -> Tree :elt)) + (define (intersection a b) + "Construct a Tree containing only those elements from `b` which are `==' to at least one element in `a`." + (fold (fn (tre elt) + (if (contains? elt tre) + (insert-or-replace tre elt) + tre)) + Empty + a)) + + (declare difference (Ord :elt => Tree :elt -> Tree :elt -> Tree :elt)) + (define (difference a b) + "Construct a Tree containing only those elements from `b` which are not `==' to any elements in `a`." + (fold (flip without) a b)) + + (declare sdifference (Ord :elt => Tree :elt -> Tree :elt -> Tree :elt)) + (define (sdifference a b) + "Symmetric difference. + +Construct a Tree containing only those elements of `a` and `b` which are not `==' to any elements in the other." + (merge (difference a b) + (difference b a))) (define-instance (Ord :elt => Semigroup (Tree :elt)) (define <> merge)) diff --git a/library/string.lisp b/library/string.lisp index e2e7fb6ca..d397ca28d 100644 --- a/library/string.lisp +++ b/library/string.lisp @@ -218,12 +218,14 @@ does not have that suffix." (define-instance (Into Single-Float String) (define (into z) (lisp String (z) - (cl:prin1-to-string z)))) + (cl:format cl:nil "~F" z) + #+ign(cl:prin1-to-string z)))) (define-instance (Into Double-Float String) (define (into z) (lisp String (z) - (cl:prin1-to-string z)))) + (cl:format cl:nil "~F" z) + #+ign(cl:prin1-to-string z)))) (define-instance (TryInto String Integer String) (define (tryInto s) From 850fa18618a99b12f841d29c10428db112e33499 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Thu, 12 Sep 2024 17:21:04 -0700 Subject: [PATCH 10/17] Added more additions. --- library/classes.lisp | 7 ++++- library/list.lisp | 6 +++++ library/ord-tree.lisp | 2 +- src/language-macros.lisp | 58 ++++++++++++++++++++++++++++++++++++++++ src/package.lisp | 2 ++ 5 files changed, 73 insertions(+), 2 deletions(-) diff --git a/library/classes.lisp b/library/classes.lisp index 2d36faada..15d5e9ad8 100644 --- a/library/classes.lisp +++ b/library/classes.lisp @@ -30,7 +30,7 @@ #:Into #:TryInto #:Iso - #:Unwrappable #:unwrap-or-else #:with-default #:unwrap #:expect #:as-optional + #:Unwrappable #:unwrap-or-else #:with-default #:unwrap #:unwrap-into #:expect #:as-optional #:default #:defaulting-unwrap #:default?)) (in-package #:coalton-library/classes) @@ -325,6 +325,11 @@ Typical `fail` continuations are: container)))) container)) + (declare unwrap-into ((Unwrappable (Result :c)) (TryInto :a :b :c) => :a -> :b)) + (define unwrap-into + "Same as `tryInto` followed by `unwrap`." + (fn (x) (unwrap (tryinto x)))) + (declare with-default ((Unwrappable :container) => :element -> (:container :element) diff --git a/library/list.lisp b/library/list.lisp index 1d10a9b4c..2ec417538 100644 --- a/library/list.lisp +++ b/library/list.lisp @@ -34,6 +34,7 @@ #:elemIndex #:findIndex #:range + #:enumerate #:append #:concat #:concatMap @@ -289,6 +290,11 @@ (%reverse! (inner start end Nil)) (inner end start Nil)))) + (declare enumerate ((Num :int) (Ord :int) => List :a -> List (Tuple :int :a))) + (define (enumerate xs) + "Pair successive zero-based indices with elements from `xs`." + (iter:collect! (iter:enumerate! (iter:into-iter xs)))) + (define (append-rev list result) (match list ((Nil) result) diff --git a/library/ord-tree.lisp b/library/ord-tree.lisp index 5cb9360c2..635aadf0d 100644 --- a/library/ord-tree.lisp +++ b/library/ord-tree.lisp @@ -529,7 +529,7 @@ B'. Which one is chosen for the result is undefined." (define (intersection a b) "Construct a Tree containing only those elements from `b` which are `==' to at least one element in `a`." (fold (fn (tre elt) - (if (contains? elt tre) + (if (contains? elt b) (insert-or-replace tre elt) tre)) Empty diff --git a/src/language-macros.lisp b/src/language-macros.lisp index 88e2eb446..130eb32b8 100644 --- a/src/language-macros.lisp +++ b/src/language-macros.lisp @@ -29,6 +29,64 @@ Note that this may copy the object or allocate memory." `(fn (,lexpr) (the ,type (,into ,lexpr))))))) +(cl:defmacro try-as (type cl:&optional (expr cl:nil expr-supplied-p)) + "A syntactic convenience for type casting. + + (try-as ) + +is equivalent to + + (the (Result :_ ) (tryInto )) + +and + + (try-as ) + +is equivalent to + + (fn (expr) (the (Result :_ ) (tryInto expr))). + +Note that this may copy the object or allocate memory." + + (cl:let ((try-into (cl:ignore-errors (cl:find-symbol "TRYINTO" "COALTON-LIBRARY/CLASSES"))) + (Result (cl:ignore-errors (cl:find-symbol "RESULT" "COALTON-LIBRARY/CLASSES")))) + (cl:assert try-into () "`try-as` macro does not have access to `try-into` yet.") + (cl:assert Result () "`try-as` macro does not have access to `Result` yet.") + (cl:if expr-supplied-p + `(the (,Result :_ ,type) (,try-into ,expr)) + (alexandria:with-gensyms (lexpr) + `(fn (,lexpr) + (the (,Result :_ ,type) (,try-into ,lexpr))))))) + +(cl:defmacro unwrap-as (type cl:&optional (expr cl:nil expr-supplied-p)) + "A syntactic convenience for type casting. + + (unwrap-as ) + +is equivalent to + + (the (uwrap (tryInto ))) + +and + + (unwrap-as ) + +is equivalent to + + (fn (expr) (the (unwrap (tryInto expr)))). + +Note that this may copy the object or allocate memory." + + (cl:let ((try-into (cl:ignore-errors (cl:find-symbol "TRYINTO" "COALTON-LIBRARY/CLASSES"))) + (unwrap (cl:ignore-errors (cl:find-symbol "UNWRAP" "COALTON-LIBRARY/CLASSES")))) + (cl:assert try-into () "`try-as` macro does not have access to `try-into` yet.") + (cl:assert unwrap () "`unwrap` macro does not have access to `unwrap` yet.") + (cl:if expr-supplied-p + `(the ,type (,unwrap (,try-into ,expr))) + (alexandria:with-gensyms (lexpr) + `(fn (,lexpr) + (the ,type (,unwrap (,try-into ,lexpr)))))))) + (cl:defmacro nest (cl:&rest items) "A syntactic convenience for function application. Transform diff --git a/src/package.lisp b/src/package.lisp index 8e88261ed..8f573af3b 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -88,6 +88,8 @@ #:or #:cond #:as + #:try-as + #:unwrap-as #:nest #:pipe #:.< From 11287ac35c9e9e84b7bf3882322949707bc3901a Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Fri, 13 Sep 2024 10:39:33 -0700 Subject: [PATCH 11/17] Added mcommute? --- library/classes.lisp | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/library/classes.lisp b/library/classes.lisp index 15d5e9ad8..eeb1aa401 100644 --- a/library/classes.lisp +++ b/library/classes.lisp @@ -23,7 +23,7 @@ #:>> #:join #:MonadFail #:fail #:Alternative #:alt #:empty - #:Foldable #:fold #:foldr #:mconcat #:mconcatmap + #:Foldable #:fold #:foldr #:mconcat #:mconcatmap #:mcommute? #:Traversable #:traverse #:Bifunctor #:bimap #:map-fst #:map-snd #:sequence @@ -242,6 +242,11 @@ "Map a container to a container of monoids, and then fold that container into a single element." (fold (fn (a b) (<> a (f b))) mempty)) + (declare mcommute? ((Eq :a) (Monoid :a) => :a -> :a -> Boolean)) + (define (mcommute? a b) + "Does `a <> b` `==' `b <> a`?" + (== (<> a b) (<> b a))) + (define-class (Traversable :t) (traverse (Applicative :f => (:a -> :f :b) -> :t :a -> :f (:t :b)))) From 3cba1a8a6663d2dd99bf75485696cfbddb1e07f4 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Fri, 13 Sep 2024 15:48:56 -0700 Subject: [PATCH 12/17] Added apply macro --- src/language-macros.lisp | 13 +++++++++++++ src/package.lisp | 1 + 2 files changed, 14 insertions(+) diff --git a/src/language-macros.lisp b/src/language-macros.lisp index 130eb32b8..6611f7d4f 100644 --- a/src/language-macros.lisp +++ b/src/language-macros.lisp @@ -113,6 +113,19 @@ to (cl:assert (cl:<= 2 (cl:list-length items))) `(nest ,@(cl:reverse items))) +(cl:defmacro apply (cl:&rest items) + "A syntactic convenience for function application. Transform + + (APPLY w x y z) + +to + + (fn (f) (f w x y z))." + + (alexandria:with-gensyms (f) + `(fn (,f) + (,f ,@items)))) + (cl:defmacro .< (cl:&rest items) "Right associative compose operator. Creates a new functions that will run the functions right to left when applied. This is the same as the NEST macro without supplying diff --git a/src/package.lisp b/src/package.lisp index 8f573af3b..c90866f55 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -92,6 +92,7 @@ #:unwrap-as #:nest #:pipe + #:apply #:.< #:.> #:make-list From 587bf1a7ca9bb7a8352047989f2f34d62dae0a8f Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Fri, 13 Sep 2024 15:53:03 -0700 Subject: [PATCH 13/17] Revert "Added apply macro" This reverts commit fb938cb8fb9cc7bf0d17d34b4f4abc1589829757. --- src/language-macros.lisp | 13 ------------- src/package.lisp | 1 - 2 files changed, 14 deletions(-) diff --git a/src/language-macros.lisp b/src/language-macros.lisp index 6611f7d4f..130eb32b8 100644 --- a/src/language-macros.lisp +++ b/src/language-macros.lisp @@ -113,19 +113,6 @@ to (cl:assert (cl:<= 2 (cl:list-length items))) `(nest ,@(cl:reverse items))) -(cl:defmacro apply (cl:&rest items) - "A syntactic convenience for function application. Transform - - (APPLY w x y z) - -to - - (fn (f) (f w x y z))." - - (alexandria:with-gensyms (f) - `(fn (,f) - (,f ,@items)))) - (cl:defmacro .< (cl:&rest items) "Right associative compose operator. Creates a new functions that will run the functions right to left when applied. This is the same as the NEST macro without supplying diff --git a/src/package.lisp b/src/package.lisp index c90866f55..8f573af3b 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -92,7 +92,6 @@ #:unwrap-as #:nest #:pipe - #:apply #:.< #:.> #:make-list From e2d17a7afae97d170e356cafa0e93432b49b103b Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Mon, 16 Sep 2024 09:26:48 -0700 Subject: [PATCH 14/17] Fixed docstring typo. Co-authored-by: Thomas Draper --- library/ord-map.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/ord-map.lisp b/library/ord-map.lisp index c8bf7e9c8..3bed65809 100644 --- a/library/ord-map.lisp +++ b/library/ord-map.lisp @@ -247,7 +247,7 @@ operation, and therefore Map cannot implement Monoid." (define (sdifference a b) "Symmetric difference. -Construct a Map containing only those mapping sof `a` and `b` which do not associate keys `==' keys in the other." +Construct a Map containing only those mappings of `a` and `b` which do not associate keys `==' keys in the other." (let (%Map a) = a) (let (%Map b) = b) (%Map (tree:sdifference a b))) From 2aa12261e96b2bca9f882a9ed6d5f5fdea8f1bde Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Mon, 16 Sep 2024 09:27:00 -0700 Subject: [PATCH 15/17] Fixed docstring typo. Co-authored-by: Thomas Draper --- library/ord-tree.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/ord-tree.lisp b/library/ord-tree.lisp index 635aadf0d..24b1614fd 100644 --- a/library/ord-tree.lisp +++ b/library/ord-tree.lisp @@ -139,7 +139,7 @@ (declare contains? ((Ord :elt) => :elt -> (Tree :elt) -> Boolean)) (define (contains? elt tre) - "Does `tre` containan element `=='`to `elt`." + "Does `tre` contain an element `==` to `elt`." (match (lookup tre elt) ((None) False) ((Some _) True))) From 08709e42bfacb9ab398bf7c28c6cd994b8e12903 Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Tue, 17 Sep 2024 11:26:01 -0700 Subject: [PATCH 16/17] Added filtering for ord-map and -tree. --- library/ord-map.lisp | 26 ++++++++++++++++++++++++-- library/ord-tree.lisp | 33 ++++++++++++++++++++++++++++++++- 2 files changed, 56 insertions(+), 3 deletions(-) diff --git a/library/ord-map.lisp b/library/ord-map.lisp index 3bed65809..8f9693399 100644 --- a/library/ord-map.lisp +++ b/library/ord-map.lisp @@ -24,6 +24,7 @@ #:collect #:update #:merge #:union #:intersection #:difference #:sdifference + #:filter-by-key #:filter-by-value #:filter-by-entry #:zip #:zip-with-default)) (in-package :coalton-library/ord-map) @@ -176,6 +177,9 @@ If `iter` contains duplicate keys, later values will overwrite earlier values." empty iter)) + (define-instance (Ord :key => iter:FromIterator (Map :key :value) (Tuple :key :value)) + (define iter:collect! collect!)) + (declare collect ((Ord :key) (Foldable :collection) => ((:collection (Tuple :key :value)) -> (Map :key :value)))) (define (collect coll) "Construct a `Map` containing all the `(key value)` pairs in `coll`. @@ -186,8 +190,8 @@ If `coll` contains duplicate keys, later values will overwrite earlier values." empty coll)) - (define-instance (Ord :key => iter:FromIterator (Map :key :value) (Tuple :key :value)) - (define iter:collect! collect!)) + (define-instance ((Ord :key) (Foldable :collection) => (Into (:collection (Tuple :key :value)) (Map :key :value))) + (define into collect)) (declare update ((Ord :key) => (:value -> :value) -> (Map :key :value) -> :key -> (Optional (Map :key :value)))) (define (update func mp key) @@ -252,6 +256,24 @@ Construct a Map containing only those mappings of `a` and `b` which do not assoc (let (%Map b) = b) (%Map (tree:sdifference a b))) + (declare filter-by-key (Ord :key => (:key -> Boolean) -> Map :key :value -> Map :key :value)) + (define (filter-by-key keep? mp) + "Construct a Map containing only those entries of `mp` which contain keys which satisfy `keep?`." + (let (%Map mp) = mp) + (%Map (tree:filter (compose keep? key) mp))) + + (declare filter-by-value (Ord :key => (:value -> Boolean) -> Map :key :value -> Map :key :value)) + (define (filter-by-value keep? mp) + "Construct a Map containing only those entries of `mp` which contain values which satisfy `keep?`." + (let (%Map mp) = mp) + (%Map (tree:filter (compose keep? value) mp))) + + (declare filter-by-entry (Ord :key => ((Tuple :key :value) -> Boolean) -> Map :key :value -> Map :key :value)) + (define (filter-by-entry keep? mp) + "Construct a Map containing only those entries of `mp` which satisfy `keep?`." + (let (%Map mp) = mp) + (%Map (tree:filter (compose keep? into) mp))) + (declare zip (Ord :key => Map :key :value1 -> Map :key :value2 -> Map :key (Tuple :value1 :value2))) (define (zip a b) "Construct a Map associating only those keys included in both `a` and `b` to the Tuple containing their respective values." diff --git a/library/ord-tree.lisp b/library/ord-tree.lisp index 24b1614fd..6395d7232 100644 --- a/library/ord-tree.lisp +++ b/library/ord-tree.lisp @@ -19,8 +19,10 @@ #:remove #:without #:increasing-order #:decreasing-order - #:collect! + #:collect! #:collect + #:filter-collect! #:filter-collect #:merge #:union #:intersection #:difference #:sdifference + #:filter #:make)) (in-package :coalton-library/ord-tree) @@ -509,9 +511,33 @@ The result tree may be in an intermediate state with a double-black node." If ITER contains duplicates, later elements will overwrite earlier elements." (iter:fold! insert-or-replace Empty iter)) + (declare filter-collect! ((Ord :elt) => (:elt -> Boolean) -> (iter:Iterator :elt) -> (Tree :elt))) + (define (filter-collect! keep? iter) + "Construct a Tree containing only those elements of `iter` which satisfy `keep?`. + +If ITER contains duplicates, later elements will overwrite earlier elements." + (collect! (iter:filter! keep? iter))) + (define-instance (Ord :elt => iter:FromIterator (Tree :elt) :elt) (define iter:collect! collect!)) + (declare collect ((Ord :elt) (Foldable :collection) => (:collection :elt)-> (Tree :elt))) + (define (collect coll) + "Construct a Tree containing all the elements of COLL. + +If COLL contains duplicates, later elements will overwrite earlier elements." + (fold insert-or-replace Empty coll)) + + (declare filter-collect ((Ord :elt) (Foldable :collection) => (:elt -> Boolean) -> (:collection :elt)-> (Tree :elt))) + (define (filter-collect keep? coll) + "Construct a Tree containing only those elements of `coll` which satisfy `keep?`. + +If COLL contains duplicates, later elements will overwrite earlier elements." + (fold (fn (tre elt) (if (keep? elt) (insert-or-replace tre elt) tre)) Empty coll)) + + (define-instance ((Ord :elt) (Foldable :collection) => (Into (:collection :elt) (Tree :elt))) + (define into collect)) + (declare merge (Ord :elt => Tree :elt -> Tree :elt -> Tree :elt)) (define (merge a b) "Construct a Tree containing all the elements of both A and B. @@ -548,6 +574,11 @@ Construct a Tree containing only those elements of `a` and `b` which are not `== (merge (difference a b) (difference b a))) + (declare filter (Ord :elt => (:elt -> Boolean) -> Tree :elt -> Tree :elt)) + (define (filter keep? tre) + "Construct a Tree containing only those elements of `tre` which satisfy `keep?`." + (fold (fn (new-tre elt) (if (keep? elt) (insert-or-replace new-tre elt) new-tre)) Empty tre)) + (define-instance (Ord :elt => Semigroup (Tree :elt)) (define <> merge)) From 29dc11c45ba9110976664dce7f0342c538dbe2aa Mon Sep 17 00:00:00 2001 From: Yarin Heffes Date: Tue, 17 Sep 2024 12:09:01 -0700 Subject: [PATCH 17/17] Added countBy! for iter --- library/iterator.lisp | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/library/iterator.lisp b/library/iterator.lisp index e15b86728..ae689853a 100644 --- a/library/iterator.lisp +++ b/library/iterator.lisp @@ -51,6 +51,7 @@ #:and! #:or! #:count! + #:countBy! #:for-each! #:find! #:find-map! @@ -489,6 +490,11 @@ This operation could be called `length!`, but `count!` emphasizes the fact that afterwards, ITER will be exhausted." (sum! (map (const 1) iter))) + (declare countBy! ((:elt -> Boolean) -> Iterator :elt -> UFix)) + (define (countBy! f iter) + "Count the number of items in `iter` that satisfy the predicate `f`." + (sum! (map (fn (elt) (if (f elt) 1 0)) iter))) + (declare for-each! ((:elt -> Unit) -> Iterator :elt -> Unit)) (define (for-each! thunk iter) "Call THUNK on each element of ITER in order for side effects.