diff --git a/aoc2024/Day10.newt b/aoc2024/Day10.newt index beaa279..fc57034 100644 --- a/aoc2024/Day10.newt +++ b/aoc2024/Day10.newt @@ -31,12 +31,6 @@ instance Ord Point where instance Eq Point where (a,b) == (c,d) = a == c && b == d -swap : ∀ a b. a × b → b × a -swap (a,b) = (b,a) - -const : ∀ a b. a → b → a -const a b = a - -- TODO add parameter a and pass Char -> a into getGrid Grid : U Grid = SortedMap Point Int diff --git a/aoc2024/SortedMap.newt b/aoc2024/SortedMap.newt index f661b08..264131d 100644 --- a/aoc2024/SortedMap.newt +++ b/aoc2024/SortedMap.newt @@ -2,6 +2,10 @@ module SortedMap import Prelude +-- TODO We'll want to replace Ord/Eq with (a → Ordering) (and rewrite most of our aoc solutions...) +-- data Ordering : U where +-- LT EQ GT : Ordering + 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 @@ -43,9 +47,127 @@ insertT23 key value (Node3 t1 k1 t2 k2 t3) = 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}} {{Eq k}} → (h : Nat) -> k -> T23 h k v -> Either (T23 h k v) (Hole h k v) +deleteT23 Z key (Leaf k v) = if k == key then Right MkUnit else 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 - MapOf : ∀ k v h. T23 h 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}} {{Eq 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. {{Eq k}} {{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}} {{Eq k}} -> k -> SortedMap k v -> Maybe (k × v) lookupMap k EmptyMap = Nothing diff --git a/newt/Prelude.newt b/newt/Prelude.newt index 9425e05..75facd2 100644 --- a/newt/Prelude.newt +++ b/newt/Prelude.newt @@ -637,8 +637,8 @@ instance Cast Int Double where instance Applicative IO where return a = \ w => MkIORes a w f <*> a = \ w => - let (MkIORes f w) = trace "fw" $ f w in - let (MkIORes a w) = trace "aw" $ a w in + let (MkIORes f w) = f w in + let (MkIORes a w) = a w in MkIORes (f a) w class Bifunctor (f : U → U → U) where @@ -740,3 +740,6 @@ instance Cast Int Nat where instance Show Char where show c = jsShow c + +swap : ∀ a b. a × b → b × a +swap (a,b) = (b,a) diff --git a/playground/samples/Combinatory.newt b/playground/samples/Combinatory.newt index 2a253af..01142b3 100644 --- a/playground/samples/Combinatory.newt +++ b/playground/samples/Combinatory.newt @@ -79,9 +79,10 @@ sapp (CApp K t) I = t sapp (CApp K t) (CApp K u) = CApp K (CApp t u) -- was out of pattern because of unexpanded lets. sapp (CApp K t) u = CApp (CApp B t) u --- TODO unsolved meta, out of pattern fragment +-- TODO unsolved meta, out of pattern fragment (now it's skolem - from changes to updateContext?) +-- so I may need to point the var -> var in another direction (hopefully something simple) sapp t (CApp K u) = ? -- CApp (CApp C t) u --- TODO unsolved meta, out of pattern fragment +-- TODO unsolved meta, out of pattern fragment (ditto, skolem) sapp t u = ? -- CApp (CApp S t) u abs : {Γ : Ctx} {σ τ : Type} {f : _} → Comb (σ :: Γ) τ f → Comb Γ (σ ~> τ) (\ env x => f (x ::: env)) diff --git a/src/Lib/Elab.idr b/src/Lib/Elab.idr index 92fef37..a7e6cdf 100644 --- a/src/Lib/Elab.idr +++ b/src/Lib/Elab.idr @@ -517,13 +517,31 @@ substVal k v tm = go tm -- go (VLit x y) = ?rhs_8 +-- need to turn k into a ground value + +-- TODO rework this to do something better. We've got constraints, and +-- and may need to do proper unification if it's already defined to a value +-- below we're handling the case if it's defined to another var, but not +-- checking for loops. updateContext : Context -> List (Nat, Val) -> M Context updateContext ctx [] = pure ctx -updateContext ctx ((k, val) :: cs) = let ix = (length ctx.env `minus` k) `minus` 1 in - updateContext ({env $= map (substVal k val), bds $= replaceV ix Defined } ctx) cs +updateContext ctx ((k, val) :: cs) = + let ix = (length ctx.env `minus` k) `minus` 1 in + case getAt ix ctx.env of + (Just (VVar _ k' [<])) => + if k' /= k + then updateContext ctx ((k',val) :: cs) + else updateContext ({env $= map (substVal k val), bds $= replaceV ix Defined } ctx) cs + (Just val') => do + -- This is fine for Z =?= Z but for other stuff, we probably have to match + info (getFC val) "need to unify \{show val} and \{show val'} or something" + updateContext ctx cs + Nothing => error (getFC val) "INTERNAL ERROR: bad index in updateContext" + + -- -- updateContext ({env $= replace ix val, bds $= replaceV ix Defined } ctx) cs where - replace : Nat -> a -> List a -> List a + replace : Nat -> Val -> List Val -> List Val replace k x [] = [] replace 0 x (y :: xs) = x :: xs replace (S k) x (y :: xs) = y :: replace k x xs @@ -562,16 +580,29 @@ buildCase ctx prob scnm scty (dcName, arity, ty) = do let (VRef _ sctynm _ _) = scty | _ => error (getFC scty) "case split on non-inductive \{show scty}" case lookupDef ctx scnm of + -- NOW this is S var7 Just val@(VRef fc nm y sp) => if nm /= dcName then do debug "SKIP \{dcName} because \{scnm} forced to \{show val}" pure Nothing else do - debug "DOTTED \{dcName} \{show val}" + debug "case \{dcName} dotted \{show val}" + when (length vars /= length sp) $ error emptyFC "\{show $ length vars} vars /= \{show $ length sp}" + + -- TODO - do we need this one? + -- Constrain the scrutinee's variable to be dcon applied to args + -- let Just x = findIndex ((==scnm) . fst) ctx'.types + -- | Nothing => error ctx.fc "\{scnm} not is scope?" + -- let lvl = ((length ctx'.env) `minus` (cast x)) `minus` 1 + -- let scon : (Nat, Val) = (lvl, VRef ctx.fc dcName (DCon arity dcName) sc) -- TODO - I think we need to define the context vars to sp via updateContext + let lvl = (length ctx'.env `minus` length vars) + let scons = constrainSpine lvl (sp <>> []) -- REVIEW is this the right order? + ctx' <- updateContext ctx' scons + debug "(dcon \{show dcName} ty \{show ty'} scty \{show scty}" debug "(dcon \{show dcName}) (vars \{show vars}) clauses were" for_ prob.clauses $ (\x => debug " \{show x}") @@ -620,6 +651,10 @@ buildCase ctx prob scnm scty (dcName, arity, ty) = do tm <- buildTree ctx' (MkProb clauses prob.ty) pure $ Just $ CaseCons dcName (map getName vars) tm where + constrainSpine : Nat -> List Val -> List (Nat, Val) + constrainSpine lvl [] = [] + constrainSpine lvl (v :: vs) = (lvl, v) :: constrainSpine (S lvl) vs + getName : Bind -> String getName (MkBind nm _ _) = nm