port aoc2023 day4

more stuff in Prelude, typechecking fixes, solving autos
2024-11-30 10:27:06 -08:00
parent baeaf4295d
commit d5a4d6253f
10 changed files with 234 additions and 41 deletions
--- a/TODO.md
+++ b/TODO.md
@@ -1,17 +1,19 @@

 ## TODO

+- [ ] Add icit to Lam (see `check` for details)
 - [ ] TCO? Probably needed in browser, since v8 doesn't do it. bun and JavaScriptCore do support it.
- [ ] Fix string printing to be js instead of weird Idris strings
+- [x] Fix string printing to be js instead of weird Idris strings
 - [ ] make $ special
  - Makes inference easier, cleaner output, and allows `foo $ \ x => ...`
  - remove hack from Elab.infer
 - [ ] Support @ on the LHS
 - [ ] records
- [ ] `Inhabited (List a)` isn't solving if I have `instance ∀ a. Inhabited (List a)`
 - [ ] rework unify case tree
  - Idris needs help with the case tree to keep code size down, do it in stages, one dcon at a time.
 - [ ] Strategy to avoid three copies of `Prelude.newt` in this source tree
+- [ ] `mapM` needs inference help when scrutinee (see Day2.newt)
+- [ ] Can't skip an auto. We need `{{_}}` to be auto or `%search` syntax.
 - [x] add filenames to FC
 - [x] maybe use backtick for javascript so we don't highlight strings as JS
 - [ ] add namespaces
@@ -85,6 +87,7 @@
 - [x] there is some zero argument application in generated code
 - [x] get equality.newt to work
  - [x] broken again because I added J, probably need to constrain scrutinee to value
+- [ ] Bad FC for missing case in where clause (probably from ctx)
 - [x] inline metas.  Maybe zonk after TC/elab
 - [x] implicit patterns
 - [x] operators
@@ -140,3 +143,15 @@

 - [ ] Name space flattening makes it a bit more subtle when a misspelled (or shadowed) constructor turns into a variable.

+### Error Messages
+
+Missing `Monad Maybe` looks like:
+```
+Unsolved meta 358 Normal type U 0 constraints
+Unsolved meta 356 Auto type Monad (?m:355 s:0) 0 constraints
+Unsolved meta 355 Normal type U -> U 2 constraints
+  * (m355 (%var0 (List (%meta 358 [1 sp]))) =?= (Maybe (List Card))
+  * (m355 (%var0 (%meta 358 [1 sp])) =?= (Maybe Card)
+```
+There is some information here, but it's obtuse.  One issue is that I'm taking an Agda-inspired approach to search (try every option and see if exactly one works with our constraints) rather than Idris (assume the determinant on an interface is injective and solve `m344 %var0` with `Maybe`).
+
--- a/aoc2023/Day2.newt
+++ b/aoc2023/Day2.newt
@@ -21,14 +21,6 @@ pfunc repr : {a : U} -> a -> String := `(a,o) => ''+o`
 pfunc jrepr : {a : U} -> a -> String := `(a,o) => JSON.stringify(o, null, '  ')`
 pfunc toInt : String -> Int := `s => Number(s)`

-mapM : ∀ a b c. (a -> Either b c) -> List a -> Either b (List c)
-mapM f Nil = Right Nil
-mapM f (x :: xs) = case f x of
-  Left msg => Left msg
-  Right v => case mapM f xs of
-    Left msg => Left msg
-    Right vs => Right $ v :: vs
-
 maxd : Draw -> Draw -> Draw
 maxd (a,b,c) (d,e,f) = (max a d, max b e, max c f)

@@ -42,8 +34,10 @@ parseColor line = case split line " " of
  (n :: "blue" :: Nil) => Right (0,0,toInt n)
  x => Left $ "Bad draw" ++ repr x

+-- FIXME implicit isn't being solved in time here.
 parseDraw : String -> Either String Draw
-parseDraw line = case mapM parseColor $ split line ", " of
+parseDraw line =
+  case mapM {Either String} parseColor $ split line ", " of
    Right parts => Right $ foldl maxd (0,0,0) parts
    Left err => Left err

@@ -55,7 +49,7 @@ parseGame line =
    (a :: b :: Nil) => case split a " " of
      ("Game" :: ns :: Nil) =>
        let num = toInt ns in
-        case mapM parseDraw $ split b "; " of
+        case mapM {Either String} parseDraw $ split b "; " of
          Right parts => Right $ MkGame num parts
          Left err => Left err
      _ => Left "No Game"
@@ -79,7 +73,7 @@ run : String -> IO Unit
 run fn = do
  putStrLn fn
  text <- readFile fn
-  case mapM parseGame (split (trim text) "\n") of
+  case mapM {Either String} parseGame (split (trim text) "\n") of
    Left err => putStrLn $ "fail " ++ err
    Right games => do
      putStrLn "part1"
--- a/aoc2023/Day3.newt
+++ b/aoc2023/Day3.newt
@@ -6,7 +6,6 @@ import Node
 pfunc repr : {a : U} -> a -> String := `(a,o) => ''+o`
 pfunc jrepr : {a : U} -> a -> String := `(a,o) => JSON.stringify(o, null, '  ')`

-pfunc trace : ∀ a. String -> a -> a := `(_, msg, a) => { console.log(msg,debugStr(_,a)); return a }`

 maybe : ∀ a b. b → (a → b) → Maybe a → b
 maybe def f Nothing = def
--- a/aoc2023/Day4.newt
+++ b/aoc2023/Day4.newt
@@ -0,0 +1,67 @@
+module Day4
+
+import Prelude
+import Node
+
+Round : U
+Round = List Int × List Int
+
+parseRound : String → Maybe Round
+parseRound s =
+  case split s ": " of
+    (a :: b :: Nil) => case split b " | " of
+      (l :: r :: Nil) => Just (nums l, nums r)
+      _ => Nothing
+    _ => Nothing
+  where
+    -- Nat or Int here?
+    nums : String → List Int
+    -- catch - split returns empty strings that become zeros
+    nums s = map stringToInt $ filter (_/=_ "") $ split (trim s) " "
+
+parse : String -> Maybe (List Round)
+parse s = mapM parseRound (split (trim s) "\n")
+
+pfunc pow : Int → Int → Int := `(x,y) => x ** y`
+
+part1 : List Round → Int
+part1 rounds = foldl _+_ 0 $ map score rounds
+  where
+    -- TODO we'll keep the math in Int land until we have magic Nat
+    score : Round → Int
+    score (a,b) = let count = natToInt $ length $ filter (\ n => elem n b) a
+      in if count == 0 then 0 else pow 2 (count - 1)
+
+part2 : List Round → Int
+part2 rounds = go 0 $ map (_,_ 1) rounds
+  where
+    mark : Int -> Nat → List (Int × Round) → List (Int × Round)
+    mark _ _ Nil = Nil
+    mark v Z rounds = rounds
+    mark v (S k) ((cnt, round) :: rounds) = (cnt + v, round) :: mark v k rounds
+
+    go : Int → List (Int × Round) → Int
+    go acc Nil = acc
+    go acc ((cnt, a, b) :: rounds) =
+      let n = length $ filter (\ n => elem n b) a
+      in go (acc + cnt) $ mark cnt n rounds
+
+run : String -> IO Unit
+run fn = do
+  putStrLn fn
+  text <- readFile fn
+
+  case parse text of
+    Nothing => putStrLn "fail"
+    Just cards => do
+      putStrLn "part1"
+      printLn (part1 cards)
+      putStrLn "part2"
+      printLn (part2 cards)
+
+-- 13/30
+-- 25004/14427616
+main : IO Unit
+main = do
+  run "aoc2023/day4/eg.txt"
+  run "aoc2023/day4/input.txt"
--- a/aoc2023/Prelude.newt
+++ b/aoc2023/Prelude.newt
@@ -26,6 +26,10 @@ infixl 6 _==_
 class Eq a where
  _==_ : a → a → Bool

+infixl 6 _/=_
+_/=_ : ∀ a. {{Eq a}} → a → a → Bool
+a /= b = not (a == b)
+
 data Nat : U where
  Z : Nat
  S : Nat -> Nat
@@ -159,6 +163,14 @@ class Applicative (f : U → U) where
  return : {0 a} → a → f a
  _<*>_ : {0 a b} -> f (a → b) → f a → f b

+class Traversable (t : U → U) where
+  traverse : {f : U → U} → {{appf : Applicative f}} → {a : U} → {b : U} → (a → f b) → t a → f (t b)
+
+instance Applicative Maybe where
+  return a = Just a
+  Nothing <*> _ = Nothing
+  Just f <*> fa = f <$> fa
+
 infixr 2 _<|>_
 class Alternative (m : U → U) where
  _<|>_ : {0 a} → m a → m a → m a
@@ -306,6 +318,21 @@ instance Monad List where
  bind Nil amb = Nil
  bind (x :: xs) amb = amb x ++ bind xs amb

+
+
+-- This is traverse, but we haven't defined Traversable yet
+mapA : ∀ m. {{Applicative m}} {0 a b} → (a → m b) → List a → m (List b)
+mapA f Nil = return Nil
+mapA f (x :: xs) = return _::_ <*> f x <*> mapA f xs
+
+
+mapM : ∀ m. {{Monad m}} {0 a b} → (a → m b) → List a → m (List b)
+mapM f Nil = pure Nil
+mapM f (x :: xs) = do
+  b <- f x
+  bs <- mapM f xs
+  pure (b :: bs)
+
 class HasIO (m : U -> U) where
  liftIO : ∀ a. IO a → m a

@@ -483,3 +510,30 @@ getAt! : ∀ a. {{Inhabited a}} → Nat → List a → a
 getAt! _ Nil = default
 getAt! Z (x :: xs) = x
 getAt! (S k) (x :: xs) = getAt! k xs
+
+
+instance ∀ a. Applicative (Either a) where
+  return b = Right b
+  Right x <*> Right y = Right (x y)
+  Left x <*> _ = Left x
+  Right x <*> Left y = Left y
+
+instance ∀ a. Monad (Either a) where
+  pure x = Right x
+  bind (Right x) mab = mab x
+  bind (Left x) mab = Left x
+
+instance Monad Maybe where
+  pure x = Just x
+  bind Nothing mab = Nothing
+  bind (Just x) mab = mab x
+
+
+elem : ∀ a. {{Eq a}} → a → List a → Bool
+elem v Nil = False
+elem v (x :: xs) = if v == x then True else elem v xs
+
+-- TODO no empty value on my `Add`, I need a group..
+-- sum : ∀ a. {{Add a}} → List a → a
+-- sum xs = foldl _+_
+pfunc trace uses (debugStr) : ∀ a. String -> a -> a := `(_, msg, a) => { console.log(msg,debugStr(_,a)); return a }`
--- a/aoc2023/day4/eg.txt
+++ b/aoc2023/day4/eg.txt
@@ -0,0 +1,6 @@
+Card 1: 41 48 83 86 17 | 83 86  6 31 17  9 48 53
+Card 2: 13 32 20 16 61 | 61 30 68 82 17 32 24 19
+Card 3:  1 21 53 59 44 | 69 82 63 72 16 21 14  1
+Card 4: 41 92 73 84 69 | 59 84 76 51 58  5 54 83
+Card 5: 87 83 26 28 32 | 88 30 70 12 93 22 82 36
+Card 6: 31 18 13 56 72 | 74 77 10 23 35 67 36 11
--- a/playground/samples/Day2.newt
+++ b/playground/samples/Day2.newt
@@ -26,14 +26,6 @@ pfunc repr : {a : U} -> a -> String := `(a,o) => ''+o`
 pfunc jrepr : {a : U} -> a -> String := `(a,o) => JSON.stringify(o, null, '  ')`
 pfunc toInt : String -> Int := `s => Number(s)`

-mapM : ∀ a b c. (a -> Either b c) -> List a -> Either b (List c)
-mapM f Nil = Right Nil
-mapM f (x :: xs) = case f x of
-  Left msg => Left msg
-  Right v => case mapM f xs of
-    Left msg => Left msg
-    Right vs => Right $ v :: vs
-
 maxd : Draw -> Draw -> Draw
 maxd (a,b,c) (d,e,f) = (max a d, max b e, max c f)

@@ -48,7 +40,7 @@ parseColor line = case split line " " of
  x => Left $ "Bad draw" ++ repr x

 parseDraw : String -> Either String Draw
-parseDraw line = case mapM parseColor $ split line ", " of
+parseDraw line = case mapM {Either String} parseColor $ split line ", " of
  Right parts => Right $ foldl maxd (0,0,0) parts
  Left err => Left err

@@ -60,7 +52,7 @@ parseGame line =
    (a :: b :: Nil) => case split a " " of
      ("Game" :: ns :: Nil) =>
        let num = toInt ns in
-        case mapM parseDraw $ split b "; " of
+        case mapM {Either String} parseDraw $ split b "; " of
          Right parts => Right $ MkGame num parts
          Left err => Left err
      _ => Left "No Game"
@@ -85,7 +77,7 @@ part2 (MkGame n parts :: rest) =
 run : String -> Async Unit
 run fn = do
  text <- fetchText fn
-  case mapM parseGame (split (trim text) "\n") of
+  case mapM {Either String} parseGame (split (trim text) "\n") of
    Left err => putStrLn $ "fail " ++ err
    Right games => do
      putStrLn "part1"
--- a/playground/samples/Prelude.newt
+++ b/playground/samples/Prelude.newt
@@ -26,6 +26,10 @@ infixl 6 _==_
 class Eq a where
  _==_ : a → a → Bool

+infixl 6 _/=_
+_/=_ : ∀ a. {{Eq a}} → a → a → Bool
+a /= b = not (a == b)
+
 data Nat : U where
  Z : Nat
  S : Nat -> Nat
@@ -159,6 +163,14 @@ class Applicative (f : U → U) where
  return : {0 a} → a → f a
  _<*>_ : {0 a b} -> f (a → b) → f a → f b

+class Traversable (t : U → U) where
+  traverse : {f : U → U} → {{appf : Applicative f}} → {a : U} → {b : U} → (a → f b) → t a → f (t b)
+
+instance Applicative Maybe where
+  return a = Just a
+  Nothing <*> _ = Nothing
+  Just f <*> fa = f <$> fa
+
 infixr 2 _<|>_
 class Alternative (m : U → U) where
  _<|>_ : {0 a} → m a → m a → m a
@@ -306,6 +318,21 @@ instance Monad List where
  bind Nil amb = Nil
  bind (x :: xs) amb = amb x ++ bind xs amb

+
+
+-- This is traverse, but we haven't defined Traversable yet
+mapA : ∀ m. {{Applicative m}} {0 a b} → (a → m b) → List a → m (List b)
+mapA f Nil = return Nil
+mapA f (x :: xs) = return _::_ <*> f x <*> mapA f xs
+
+
+mapM : ∀ m. {{Monad m}} {0 a b} → (a → m b) → List a → m (List b)
+mapM f Nil = pure Nil
+mapM f (x :: xs) = do
+  b <- f x
+  bs <- mapM f xs
+  pure (b :: bs)
+
 class HasIO (m : U -> U) where
  liftIO : ∀ a. IO a → m a

@@ -483,3 +510,30 @@ getAt! : ∀ a. {{Inhabited a}} → Nat → List a → a
 getAt! _ Nil = default
 getAt! Z (x :: xs) = x
 getAt! (S k) (x :: xs) = getAt! k xs
+
+
+instance ∀ a. Applicative (Either a) where
+  return b = Right b
+  Right x <*> Right y = Right (x y)
+  Left x <*> _ = Left x
+  Right x <*> Left y = Left y
+
+instance ∀ a. Monad (Either a) where
+  pure x = Right x
+  bind (Right x) mab = mab x
+  bind (Left x) mab = Left x
+
+instance Monad Maybe where
+  pure x = Just x
+  bind Nothing mab = Nothing
+  bind (Just x) mab = mab x
+
+
+elem : ∀ a. {{Eq a}} → a → List a → Bool
+elem v Nil = False
+elem v (x :: xs) = if v == x then True else elem v xs
+
+-- TODO no empty value on my `Add`, I need a group..
+-- sum : ∀ a. {{Add a}} → List a → a
+-- sum xs = foldl _+_
+pfunc trace uses (debugStr) : ∀ a. String -> a -> a := `(_, msg, a) => { console.log(msg,debugStr(_,a)); return a }`
--- a/src/Lib/Elab.idr
+++ b/src/Lib/Elab.idr
@@ -944,16 +944,6 @@ check ctx tm ty = case (tm, !(forceType ctx.env ty)) of
  (t@(RLam _ (BI fc nm icit quant) tm), ty) =>
            error fc "Expected pi type, got \{!(prvalCtx ty)}"

-  (tm, ty@(VPi fc nm' Implicit rig a b)) => do
-    let names = toList $ map fst ctx.types
-    debug "XXX edge case add implicit lambda {\{nm'} : \{show a}} to \{show tm} "
-    let var = VVar fc (length ctx.env) [<]
-    ty' <- b $$ var
-    debugM $ pure "XXX ty' is \{!(prvalCtx {ctx=(extend ctx nm' a)} ty')}"
-    sc <- check (extend ctx nm' a) tm ty'
-    pure $ Lam (getFC tm) nm' sc
-
-  (RImplicit fc, ty) => freshMeta ctx fc ty Normal

  (RLet fc nm ty v sc, rty) => do
    ty' <- check ctx ty (VU emptyFC)
@@ -964,6 +954,26 @@ check ctx tm ty = case (tm, !(forceType ctx.env ty)) of
    sc' <- check ctx' sc rty
    pure $ Let fc nm v' sc'

+  (RImplicit fc, ty) => freshMeta ctx fc ty Normal
+
+  (tm, ty@(VPi fc nm' Implicit rig a b)) => do
+    let names = toList $ map fst ctx.types
+    debug "XXX edge case add implicit lambda {\{nm'} : \{show a}} to \{show tm} "
+    let var = VVar fc (length ctx.env) [<]
+    ty' <- b $$ var
+    debugM $ pure "XXX ty' is \{!(prvalCtx {ctx=(extend ctx nm' a)} ty')}"
+    sc <- check (extend ctx nm' a) tm ty'
+    pure $ Lam (getFC tm) nm' sc
+
+  (tm, ty@(VPi fc nm' Auto rig a b)) => do
+    let names = toList $ map fst ctx.types
+    debug "XXX edge case add auto lambda {\{nm'} : \{show a}} to \{show tm} "
+    let var = VVar fc (length ctx.env) [<]
+    ty' <- b $$ var
+    debugM $ pure "XXX ty' is \{!(prvalCtx {ctx=(extend ctx nm' a)} ty')}"
+    sc <- check (extend ctx nm' a) tm ty'
+    pure $ Lam (getFC tm) nm' sc
+
  (tm,ty) => do
    -- We need to insert if tm is not an Implicit Lam
    -- assuming all of the implicit ty have been handled above
@@ -972,8 +982,10 @@ check ctx tm ty = case (tm, !(forceType ctx.env ty)) of
      -- Kovacs doesn't insert on tm = Implicit Lam, we don't have Plicity in Lam
      -- so I'll check the inferred type for an implicit pi
      -- This seems wrong, the ty' is what insert runs on, so we're just short circuiting here
-      (tm'@(Lam{}), ty'@(VPi _ _ Implicit rig _ _)) => do debug "CheckMe 1"; pure (tm', ty')
-      (tm'@(Lam{}), ty'@(VPi _ _ Auto rig _ _)) => do debug "CheckMe 2"; pure (tm', ty')
+
+      -- REVIEW - I think we need icit on Lam, check that they match and drop the two "edge" above?
+      -- (tm'@(Lam{}), ty'@(VPi _ _ Implicit rig _ _)) => do debug "CheckMe 1"; pure (tm', ty')
+      -- (tm'@(Lam{}), ty'@(VPi _ _ Auto rig _ _)) => do debug "CheckMe 2"; pure (tm', ty')
      (tm', ty') => do
        debug "RUN INSERT ON \{pprint names tm'} at \{show ty'}"
        insert ctx tm' ty'
@@ -1009,7 +1021,7 @@ infer ctx (RApp fc t u icit) = do
        pure (Auto, t, tty)

  (a,b) <- case !(forceMeta tty) of
-    (VPi fc str icit' rig a b) => if icit' == icit then pure (a,b)
+    (VPi fc' str icit' rig a b) => if icit' == icit then pure (a,b)
        else error fc "IcitMismatch \{show icit} \{show icit'}"

    -- If it's not a VPi, try to unify it with a VPi
--- a/src/Lib/Types.idr
+++ b/src/Lib/Types.idr
@@ -525,7 +525,7 @@ freshMeta : Context -> FC -> Val -> MetaKind -> M Tm
 freshMeta ctx fc ty kind = do
  top <- get
  mc <- readIORef top.metas
-  debug "fresh meta \{show mc.next} : \{show ty}"
+  debug "fresh meta \{show mc.next} : \{show ty} (\{show kind})"
  writeIORef top.metas $ { next $= S, metas $= (Unsolved fc mc.next ctx ty kind [] ::) } mc
  pure $ applyBDs 0 (Meta fc mc.next) ctx.bds
  where