aoc2023 day2, codegen fixes, parsing fix

.gitignore

@@ -6,3 +6,4 @@ build/
 *.agda
 *.agdai
 *.js
+input.txt

TODO.md

@@ -6,6 +6,7 @@
 - [x] Case for primitives
 - [ ] aoc2023 translation
   - [x] day1
+  - [x] day2
   - some "real world" examples
 - [ ] Maybe Eq and stuff would work for typeclass without dealing with unification issues yet
 - [ ] unsolved meta errors repeat (need to freeze or only report at end)
@@ -31,6 +32,8 @@
 - [x] matching on operators
   - [x] top level
   - [x] case statements
+- [ ] Lean / Agda ⟨ ⟩
+- [ ] Lean-like .map, etc? (resolve name in namespace of target type, etc)
 - [x] ~~SKIP list syntax~~
   - Agda doesn't have it, clashes with pair syntax
 - [ ] autos / typeclass resolution

aoc2023/Day2.newt

@@ -0,0 +1,104 @@
+module Day2
+
+import Lib
+
+Draw : U
+Draw = Pair Int (Pair Int Int)
+
+data Game : U where
+  MkGame : Int -> List Draw -> Game
+
+-- Original had class and instance...
+-- Add, Sub, Mul, Neg
+
+-- NB this is not lazy!
+infixl 2 _&&_
+
+_&&_ : Bool -> Bool -> Bool
+a && b = case a of
+  False => False
+  True => b
+
+max : Int -> Int -> Int
+max x y = case x < y of
+  True => y
+  False => x
+
+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 : U} -> (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)
+
+lte : Draw -> Draw -> Bool
+lte (a,b,c) (d,e,f) = a <= d && b <= e && c <= f
+
+parseColor : String -> Either String Draw
+parseColor line = case split line " " of
+  (n :: "red" :: Nil) => Right (toInt n,0,0)
+  (n :: "green" :: Nil) => Right (0,toInt n,0)
+  (n :: "blue" :: Nil) => Right (0,0,toInt n)
+  x => Left $ "Bad draw" ++ repr x
+
+parseDraw : String -> Either String Draw
+parseDraw line = case mapM parseColor $ split line ", " of
+  Right parts => Right $ foldl maxd (0,0,0) parts
+  Left err => Left err
+
+parseGame : String -> Either String Game
+parseGame line =
+  -- Need the Idris | sugar...
+  case split line ": " of
+    -- this is splitting on the Nil instead of the a
+    (a :: b :: Nil) => case split a " " of
+      ("Game" :: ns :: Nil) =>
+        let num = toInt ns in
+        case mapM parseDraw $ split b "; " of
+          Right parts => Right $ MkGame num parts
+          Left err => Left err
+      _ => Left "No Game"
+    _ => Left $ "No colon in " ++ line
+
+infixl 3 _>>_
+
+_>>_ : {A B : U} -> A -> B -> B
+a >> b = b
+
+part1 : List Game -> Int
+part1 Nil = 0
+part1 (MkGame n parts :: rest) =
+  let total = foldl maxd (0,0,0) parts in
+  case lte total (12,13,14) of
+    True => n + part1 rest
+    False => part1 rest
+
+part2 : List Game -> Int
+part2 Nil = 0
+part2 (MkGame n parts :: rest) =
+  case foldl maxd (0,0,0) parts of
+    (a,b,c) => a*b*c + part2 rest
+
+run : String -> Dummy
+run fn =
+  let text = readFile fn in
+  case mapM parseGame (split (trim text) "\n") of
+    Left err => log $ "fail " ++ err
+    Right games =>
+      log "part1" >>
+      log (part1 games) >>
+      log "part2" >>
+      log (part2 games)
+
+main : Dummy -> Dummy
+main _ =
+  run "aoc2023/day2/eg.txt" >>
+  run "aoc2023/day2/input.txt"

aoc2023/Lib.newt

@@ -1,6 +1,8 @@
 module Lib
 
 -- Prelude
+data Unit : U where
+  MkUnit : Unit
 
 data Bool : U where
   True : Bool
@@ -35,6 +37,9 @@ reverse' (x :: xs) acc = reverse' xs (x :: acc)
 reverse : {A : U} -> List A -> List A
 reverse xs = reverse' xs Nil
 
+length : {a : U} -> List a -> Nat
+length Nil = Z
+length (x :: xs) = S (length xs)
 
 infixr 2 _,_
 
@@ -73,6 +78,20 @@ pfunc arrayToList : {a : U} -> Array a -> List a := "
 }
 "
 
+pfunc listToArray : {a : U} -> List a -> Array a := "
+(a, l) => {
+  let rval = []
+  while (l.tag !== 'Nil') {
+    rval.push(l.h1)
+    l = l.h2
+  }
+  return rval
+}
+"
+pfunc alen : {a : U} -> Array a -> Int := "(a,arr) => arr.length"
+pfunc aget : {a : U} -> Array a -> Int -> a := "(a, arr, ix) => arr[ix]"
+pfunc aempty : {a : U} -> Unit -> Array a := "() => []"
+
 pfunc getArgs : List String := "arrayToList(String, process.argv)"
 -- Maybe integrate promises?
 
@@ -80,11 +99,13 @@ pfunc getArgs : List String := "arrayToList(String, process.argv)"
 pfunc ord : Char -> Int := "(c) => c.charCodeAt(0)"
 
 pfunc _<_ : Int -> Int -> Bool := "(x,y) => (x < y) ? True : False"
+pfunc _<=_ : Int -> Int -> Bool := "(x,y) => (x <= y) ? True : False"
 pfunc _+_ : Int -> Int -> Int := "(x,y) => x + y"
 pfunc _-_ : Int -> Int -> Int := "(x,y) => x - y"
 pfunc _*_ : Int -> Int -> Int := "(x,y) => x * y"
 pfunc _/_ : Int -> Int -> Int := "(x,y) => x / y"
-infixl 3 _<_
+infix 3 _<_
+infix 3 _<=_
 infixl 4 _-_
 infixl 4 _+_
 infixl 5 _*_
@@ -109,6 +130,11 @@ pfunc split : String -> String -> List String := "(s, by) => {
   return rval
 }"
 
+pfunc slen : String -> Int := "s => s.length"
+pfunc sindex : String -> Int -> Char := "(s,i) => s[i]"
+
+
+infixl 4 _++_
 pfunc _++_ : String -> String -> String := "(a,b) => a + b"
 
 

aoc2023/day2/eg.txt

@@ -0,0 +1,5 @@
+Game 1: 3 blue, 4 red; 1 red, 2 green, 6 blue; 2 green
+Game 2: 1 blue, 2 green; 3 green, 4 blue, 1 red; 1 green, 1 blue
+Game 3: 8 green, 6 blue, 20 red; 5 blue, 4 red, 13 green; 5 green, 1 red
+Game 4: 1 green, 3 red, 6 blue; 3 green, 6 red; 3 green, 15 blue, 14 red
+Game 5: 6 red, 1 blue, 3 green; 2 blue, 1 red, 2 green

src/Lib/Compile.idr

@@ -133,7 +133,9 @@ termToJS env (CCase t alts) f =
     (Var nm) => maybeCaseStmt env nm alts
     t' => do
       -- TODO refactor nm to be a JSExp with Var{} or Dot{}
-      let nm = "sc$\{show env.depth}"
+      -- FIXME sc$ seemed to shadow something else, lets get this straightened out
+      -- we need fresh names that are not in env (i.e. do not play in debruijn)
+      let nm = "_sc$\{show env.depth}"
       let env' = { depth $= S } env
       JSnoc (JConst nm t') (maybeCaseStmt env' nm alts)
 

src/Lib/Parser.idr

@@ -124,7 +124,7 @@ letExpr = do
   alts <- startBlock $ someSame $ letAssign
   keyword' "in"
   scope <- typeExpr
-  pure $ foldl (\ acc, (n,fc,v) => RLet fc n (RImplicit fc) v acc) scope alts
+  pure $ foldl (\ acc, (n,fc,v) => RLet fc n (RImplicit fc) v acc) scope (reverse alts)
   where
     letAssign : Parser (Name,FC,Raw)
     letAssign = do

src/Main.idr

@@ -80,8 +80,9 @@ processModule base stk name = do
   top <- get
   let Right (decls, ops, toks) := partialParse (manySame parseDecl) top.ops toks
     | Left err => fail (showError src err)
-  let [] := toks | (x :: xs) => fail "extra toks" -- FIXME FC from xs
+  let [] := toks
-
+    | (x :: xs) =>
+        fail (showError src (E (startBounds x.bounds) "extra toks")) -- FIXME FC from xs
   modify { ops := ops }
 
   putStrLn "process Decls"