porting WIP

This commit is contained in:
2025-01-01 20:24:53 -08:00
parent 9ed2b2077d
commit e41e1d8f6a
24 changed files with 2118 additions and 16 deletions

1
done/Data/Fin.newt Normal file
View File

@@ -0,0 +1 @@
module Data.Fin

27
done/Data/IORef.newt Normal file
View File

@@ -0,0 +1,27 @@
module Data.IORef
import Prelude
-- We should test this at some point
ptype IORef : U U
pfunc primNewIORef uses (MkIORes MkUnit) : a. a IO (IORef a) := `(_, a) => (w) => MkIORes(undefined, [a], w)`
pfunc primReadIORef uses (MkIORes MkUnit) : a. IORef a IO a := `(_, ref) => (w) => MkIORes(undefined, ref[0], w)`
pfunc primWriteIORef uses (MkIORes MkUnit) : a. IORef a a IO a := `(_, ref, a) => (w) => {
ref[0] = a
return MkIORes(undefined,MkUnit,w)
}`
newIORef : io a. {{HasIO io}} a io (IORef a)
newIORef a = liftIO $ primNewIORef a
readIORef : io a. {{HasIO io}} IORef a io a
readIORef ref = liftIO $ primReadIORef ref
writeIORef : io a. {{HasIO io}} IORef a -> a -> io Unit
writeIORef ref a = liftIO $ writeIORef ref a
-- Idris HasIO constraints to monad, we don't have those constraints yet
modifyIORef : io a. {{Monad io}} {{HasIO io}} IORef a -> (a -> a) -> io Unit
modifyIORef {io} ref f =
bind {io} (readIORef ref) $ \a => writeIORef ref (f a)

12
done/Data/Int.newt Normal file
View File

@@ -0,0 +1,12 @@
module Data.Int
import Prelude
div : Int Int Int
div a b = a / b
instance Cast Char Int where
cast = ord
instance Cast Int String where
cast = show

1
done/Data/List.newt Normal file
View File

@@ -0,0 +1 @@
module Data.List

10
done/Data/List1.newt Normal file
View File

@@ -0,0 +1,10 @@
module Data.List1
import Prelude
infixr 7 _:::_
record List1 a where
constructor _:::_
head1 : a
tail1 : List a

1
done/Data/Maybe.newt Normal file
View File

@@ -0,0 +1 @@
module Data.Maybe

1
done/Data/Nat.newt Normal file
View File

@@ -0,0 +1 @@
module Data.Nat

14
done/Data/SnocList.newt Normal file
View File

@@ -0,0 +1,14 @@
module Data.SnocList
import Prelude
snoclen : a. SnocList a Nat
snoclen {a} xs = go xs Z
where
go : SnocList a Nat Nat
go Lin acc = acc
go (xs :< x) acc = go xs (S acc)
snocelem : a. {{Eq a}} a SnocList a Bool
snocelem a Lin = False
snocelem a (xs :< x) = if a == x then True else snocelem a xs

202
done/Data/SortedMap.newt Normal file
View File

@@ -0,0 +1,202 @@
module Data.SortedMap
import Prelude
-- TODO We'll want to replace Ord/Eq with (a → Ordering) (and rewrite most of our aoc solutions...)
data T23 : Nat -> U -> U -> U where
Leaf : k v. k -> v -> T23 Z k v
Node2 : h k v. T23 h k v -> k -> T23 h k v -> T23 (S h) k v
Node3 : h k v. T23 h k v -> k -> T23 h k v -> k -> T23 h k v -> T23 (S h) k v
lookupT23 : h k v. {{Ord k}} -> k -> T23 h k v -> Maybe (k × v)
lookupT23 key (Leaf k v)= case compare k key of
EQ => Just (k,v)
_ => Nothing
lookupT23 key (Node2 t1 k1 t2) =
if key <= k1 then lookupT23 key t1 else lookupT23 key t2
lookupT23 key (Node3 t1 k1 t2 k2 t3) =
if key <= k1 then lookupT23 key t1
else if key <= k2 then lookupT23 key t2
else lookupT23 key t3
insertT23 : h k v. {{Ord k}} -> k -> v -> T23 h k v -> Either (T23 h k v) (T23 h k v × k × T23 h k v)
insertT23 key value (Leaf k v) = case compare key k of
EQ => Left (Leaf key value)
LT => Right (Leaf key value, key, Leaf k v)
GT => Right (Leaf k v, k, Leaf key value)
insertT23 key value (Node2 t1 k1 t2) =
if key <= k1 then
case insertT23 key value t1 of
Left t1' => Left (Node2 t1' k1 t2)
Right (a,b,c) => Left (Node3 a b c k1 t2)
else case insertT23 key value t2 of
Left t2' => Left (Node2 t1 k1 t2')
Right (a,b,c) => Left (Node3 t1 k1 a b c)
insertT23 key value (Node3 t1 k1 t2 k2 t3) =
if key <= k1 then
case insertT23 key value t1 of
Left t1' => Left (Node3 t1' k1 t2 k2 t3)
Right (a,b,c) => Right (Node2 a b c, k1, Node2 t2 k2 t3)
else if key <= k2 then
case insertT23 key value t2 of
Left t2' => Left (Node3 t1 k1 t2' k2 t3)
Right (a,b,c) => Right (Node2 t1 k1 a, b, Node2 c k2 t3)
else
case insertT23 key value t3 of
Left t3' => Left (Node3 t1 k1 t2 k2 t3')
Right (a,b,c) => Right (Node2 t1 k1 t2, k2, Node2 a b c)
-- This is cribbed from Idris. Deleting nodes takes a bit of code.
Hole : Nat U U U
Hole Z k v = Unit
Hole (S n) k v = T23 n k v
Node4 : k v h. T23 h k v k T23 h k v k T23 h k v k T23 h k v T23 (S (S h)) k v
Node4 t1 k1 t2 k2 t3 k3 t4 = Node2 (Node2 t1 k1 t2) k2 (Node2 t3 k3 t4)
Node5 : k v h. T23 h k v k T23 h k v k T23 h k v k T23 h k v k T23 h k v T23 (S (S h)) k v
Node5 a b c d e f g h i = Node2 (Node2 a b c) d (Node3 e f g h i)
Node6 : k v h. T23 h k v k T23 h k v k T23 h k v k T23 h k v k T23 h k v k T23 h k v T23 (S (S h)) k v
Node6 a b c d e f g h i j k = Node2 (Node3 a b c d e) f (Node3 g h i j k)
Node7 : k v h. T23 h k v k T23 h k v k T23 h k v k T23 h k v k T23 h k v k T23 h k v k T23 h k v T23 (S (S h)) k v
Node7 a b c d e f g h i j k l m = Node3 (Node3 a b c d e) f (Node2 g h i) j (Node2 k l m)
merge1 : k v h. T23 h k v k T23 (S h) k v k T23 (S h) k v T23 (S (S h)) k v
merge1 a b (Node2 c d e) f (Node2 g h i) = Node5 a b c d e f g h i
merge1 a b (Node2 c d e) f (Node3 g h i j k) = Node6 a b c d e f g h i j k
merge1 a b (Node3 c d e f g) h (Node2 i j k) = Node6 a b c d e f g h i j k
merge1 a b (Node3 c d e f g) h (Node3 i j k l m) = Node7 a b c d e f g h i j k l m
merge2 : k v h. T23 (S h) k v k T23 h k v k T23 (S h) k v T23 (S (S h)) k v
merge2 (Node2 a b c) d e f (Node2 g h i) = Node5 a b c d e f g h i
merge2 (Node2 a b c) d e f (Node3 g h i j k) = Node6 a b c d e f g h i j k
merge2 (Node3 a b c d e) f g h (Node2 i j k) = Node6 a b c d e f g h i j k
merge2 (Node3 a b c d e) f g h (Node3 i j k l m) = Node7 a b c d e f g h i j k l m
merge3 : k v h. T23 (S h) k v k T23 (S h) k v k T23 h k v T23 (S (S h)) k v
merge3 (Node2 a b c) d (Node2 e f g) h i = Node5 a b c d e f g h i
merge3 (Node2 a b c) d (Node3 e f g h i) j k = Node6 a b c d e f g h i j k
merge3 (Node3 a b c d e) f (Node2 g h i) j k = Node6 a b c d e f g h i j k
merge3 (Node3 a b c d e) f (Node3 g h i j k) l m = Node7 a b c d e f g h i j k l m
-- height is erased in the data everywhere but the top, but needed for case
-- I wonder if we could use a 1 + 1 + 1 type instead of Either Tree Hole and condense this
deleteT23 : k v. {{Ord k}} (h : Nat) -> k -> T23 h k v -> Either (T23 h k v) (Hole h k v)
deleteT23 Z key (Leaf k v) = case compare k key of
EQ => Right MkUnit
_ => Left (Leaf k v)
deleteT23 (S Z) key (Node2 t1 k1 t2) =
if key <= k1
then case deleteT23 Z key t1 of
Left t1 => Left (Node2 t1 k1 t2)
Right _ => Right t2
else case deleteT23 Z key t2 of
Left t2 => Left (Node2 t1 k1 t2)
Right MkUnit => Right t1
deleteT23 (S Z) key (Node3 t1 k1 t2 k2 t3) =
if key <= k1
then case deleteT23 _ key t1 of
Left t1 => Left (Node3 t1 k1 t2 k2 t3)
Right MkUnit => Left (Node2 t2 k2 t3)
else if key <= k2 then case deleteT23 _ key t2 of
Left t2 => Left (Node3 t1 k1 t2 k2 t3)
Right _ => Left (Node2 t1 k1 t3)
else case deleteT23 _ key t3 of
Left t3 => Left (Node3 t1 k1 t2 k2 t3)
Right _ => Left (Node2 t1 k1 t2)
deleteT23 (S (S h)) key (Node2 t1 k1 t2) =
if key <= k1
then case deleteT23 (S h) key t1 of
Left t1 => Left (Node2 t1 k1 t2)
Right t1 => case t2 of
Node2 t2' k2' t3' => Right (Node3 t1 k1 t2' k2' t3')
Node3 t2 k2 t3 k3 t4 => Left $ Node4 t1 k1 t2 k2 t3 k3 t4
else case deleteT23 _ key t2 of
Left t2 => Left (Node2 t1 k1 t2)
Right t2 => case t1 of
Node2 a b c => Right (Node3 a b c k1 t2)
Node3 a b c d e => Left (Node4 a b c d e k1 t2)
deleteT23 (S (S h)) key (Node3 t1 k1 t2 k2 t3) =
if key <= k1
then case deleteT23 _ key t1 of
Left t1 => Left (Node3 t1 k1 t2 k2 t3)
Right t1 => Left (merge1 t1 k1 t2 k2 t3)
else if key <= k2 then case deleteT23 _ key t2 of
Left t2 => Left (Node3 t1 k1 t2 k2 t3)
Right t2 => Left (merge2 t1 k1 t2 k2 t3)
else case deleteT23 _ key t3 of
Left t3 => Left (Node3 t1 k1 t2 k2 t3)
Right t3 => Left (merge3 t1 k1 t2 k2 t3)
treeLeft : h k v. T23 h k v (k × v)
treeLeft (Leaf k v) = (k, v)
treeLeft (Node2 t1 _ _) = treeLeft t1
treeLeft (Node3 t1 _ _ _ _) = treeLeft t1
treeRight : h k v. T23 h k v (k × v)
treeRight (Leaf k v) = (k, v)
treeRight (Node2 _ _ t2) = treeRight t2
treeRight (Node3 _ _ _ _ t3) = treeRight t3
data SortedMap : U -> U -> U where
EmptyMap : k v. SortedMap k v
-- not erased so we know what happens in delete
MapOf : k v. {h : Nat} T23 h k v -> SortedMap k v
deleteMap : k v. {{Ord k}} k SortedMap k v SortedMap k v
deleteMap key EmptyMap = EmptyMap
-- REVIEW if I split h separately in a nested case, it doesn't sort out Hole
deleteMap key (MapOf {k} {v} {Z} tree) = case deleteT23 Z key tree of
Left t => MapOf t
Right t => EmptyMap
deleteMap key (MapOf {k} {v} {S n} tree) = case deleteT23 (S n) key tree of
Left t => MapOf t
Right t => MapOf t
leftMost : k v. SortedMap k v Maybe (k × v)
leftMost EmptyMap = Nothing
leftMost (MapOf m) = Just (treeLeft m)
rightMost : k v. SortedMap k v Maybe (k × v)
rightMost EmptyMap = Nothing
rightMost (MapOf m) = Just (treeRight m)
-- TODO issue with metas and case if written as `do` block
pop : k v. {{Ord k}} SortedMap k v Maybe ((k × v) × SortedMap k v)
pop m = case leftMost m of
Just (k,v) => Just ((k,v), deleteMap k m)
Nothing => Nothing
lookupMap : k v. {{Ord k}} -> k -> SortedMap k v -> Maybe (k × v)
lookupMap k EmptyMap = Nothing
lookupMap k (MapOf map) = lookupT23 k map
lookupMap' : k v. {{Ord k}} -> k -> SortedMap k v -> Maybe v
lookupMap' k EmptyMap = Nothing
lookupMap' k (MapOf map) = snd <$> lookupT23 k map
updateMap : k v. {{Ord k}} -> k -> v -> SortedMap k v -> SortedMap k v
updateMap k v EmptyMap = MapOf $ Leaf k v
updateMap k v (MapOf map) = case insertT23 k v map of
Left map' => MapOf map'
Right (a, b, c) => MapOf (Node2 a b c)
toList : k v. SortedMap k v List (k × v)
toList {k} {v} (MapOf smap) = reverse $ go smap Nil
where
go : h. T23 h k v List (k × v) List (k × v)
go (Leaf k v) acc = (k, v) :: acc
go (Node2 t1 k1 t2) acc = go t2 (go t1 acc)
go (Node3 t1 k1 t2 k2 t3) acc = go t3 $ go t2 $ go t1 acc
toList _ = Nil
foldMap : a b. {{Ord a}} (b b b) SortedMap a b List (a × b) SortedMap a b
foldMap f m Nil = m
foldMap f m ((a,b) :: xs) = case lookupMap a m of
Nothing => foldMap f (updateMap a b m) xs
Just (_, b') => foldMap f (updateMap a (f b' b) m) xs

11
done/Data/String.newt Normal file
View File

@@ -0,0 +1,11 @@
module Data.String
import Prelude
class Interpolation a where
interpolate : a String
unwords : List String String
unwords stuff = joinBy " " stuff

1
done/Data/Vect.newt Normal file
View File

@@ -0,0 +1 @@
module Data.Vect