diff --git a/.gitignore b/.gitignore index 27d61ab..6ce73d3 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ build/ *.agda *.agdai *.js +input.txt diff --git a/TODO.md b/TODO.md index b90cb4c..986fa12 100644 --- a/TODO.md +++ b/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 diff --git a/aoc2023/Day2.newt b/aoc2023/Day2.newt new file mode 100644 index 0000000..dc4adbd --- /dev/null +++ b/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" diff --git a/aoc2023/Lib.newt b/aoc2023/Lib.newt index 071f788..ca90881 100644 --- a/aoc2023/Lib.newt +++ b/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" diff --git a/aoc2023/day2/eg.txt b/aoc2023/day2/eg.txt new file mode 100644 index 0000000..295c36d --- /dev/null +++ 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 diff --git a/src/Lib/Compile.idr b/src/Lib/Compile.idr index 5c81289..16ca295 100644 --- a/src/Lib/Compile.idr +++ b/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) diff --git a/src/Lib/Parser.idr b/src/Lib/Parser.idr index 739c81e..1e496b1 100644 --- a/src/Lib/Parser.idr +++ b/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 diff --git a/src/Main.idr b/src/Main.idr index c7aefd2..55f246a 100644 --- a/src/Main.idr +++ b/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"