add recursive groups to both versions

2022-10-04 08:49:11 -05:00 · 2022-10-04 08:49:11 -05:00 · d26c29812e
parent 19643aa6c1
commit d26c29812e
9 changed files with 183 additions and 86 deletions
--- a/agda/Calc.agda
+++ b/agda/Calc.agda
@ -17,7 +17,7 @@ open import Show
 open import Util

 main : Main
-main = run (getLine >>= λ c → putStrLn (showList (showResult show) (map evalBin (takeLine (primStringToList c)))))
+main = run (getLine >>= λ c → putStrLn (showList (showResult show) (map evalExpr (takeLine (primStringToList c)))))

 -- singular version
-- main = run (getLine >>= λ c → putStrLn (showResult show (evalBin (takeBin (primStringToList c)))))
+-- main = run (getLine >>= λ c → putStrLn (showResult show (evalExpr (takeBin (primStringToList c)))))
--- a/agda/Eval.agda
+++ b/agda/Eval.agda
@ -1,6 +1,8 @@
 module Eval where

 open import Agda.Builtin.Bool
+open import Agda.Builtin.Char
+open import Agda.Builtin.List
 open import Agda.Builtin.Maybe
 open import Agda.Builtin.Nat

@ -8,14 +10,26 @@ open import Data.Nat.DivMod using (_/_)

 open import Parse

-evalBin : Result BinExpr → Result Nat
-evalBin (emit nothing rem) = emit↑ rem
-evalBin (emit (just (bin (Oper o) (Digit a) (Digit b))) rem) with o
-...                                                             | '+' = emit↓ (a + b) rem
-...                                                             | '-' = emit↓ (a - b) rem
-...                                                             | '*' = emit↓ (a * b) rem
-...                                                             | '/' with (b == zero)
-...                                                                      | true = emit↑ rem
-...                                                                      | false = emit↓ (a / (suc (b - 1))) rem -- todo: why -1 tho
-evalBin (emit (just (bin (Oper o) (Digit a) (Digit b))) rem)    | _ = emit↑ rem
-evalBin (emit (just (bin _ _ _)) rem) = emit↑ rem
+evalDiv : Nat → Nat → List Char → Result Nat
+evalDiv _ 0 s = emit↑ s
+evalDiv a b s = emit↓ (a / (suc (b - 1))) s -- todo: why suc-1 tho
+
+{-# NON_TERMINATING #-}
+evalExpr : Result Expr → Result Nat
+evalExpr (emit nothing rem) = emit↑ rem
+evalExpr (emit (just (NatExpr n)) rem) = emit↓ n rem
+evalExpr (emit (just (BinExpr oe lhs rhs)) rem) with oe
+...     | (OperExpr o) with evalExpr (emit↓ lhs []) | evalExpr (emit↓ rhs [])
+...           | emit nothing _  | _ = emit↑ rem
+...           | emit _ _        | emit nothing _ = emit↑ rem
+...           | emit (just a) _ | emit (just b) _ with o
+...                 | '+' = emit↓ (a + b) rem
+...                 | '-' = emit↓ (a - b) rem
+...                 | '*' = emit↓ (a * b) rem
+...                 | '/' = evalDiv a b rem
+...                 | _ = emit↑ rem
+evalExpr (emit (just (BinExpr oe lhs rhs)) rem)
+        | _ = emit↑ rem
+
+-- evalExpr (emit (just (BinExpr (TokenExpr (Oper o)) lhs rhs)) rem)    | _ = emit↑ rem
+evalExpr (emit (just _) rem) = emit↑ rem
--- a/agda/Parse.agda
+++ b/agda/Parse.agda
@ -8,6 +8,7 @@ open import Agda.Builtin.Nat
 open import Agda.Builtin.String

 open import Data.List using (_++_; reverse)
+open import Data.Product using (_×_)

 open import Util

@ -18,12 +19,10 @@ data Token : Set where
  Skip : Char → Token
  Term : Token

-record BinExpr : Set where
-  constructor bin
-  field
-    oper : Token
-    lhs : Token
-    rhs : Token
+data Expr : Set where
+  BinExpr : Expr → Expr → Expr → Expr
+  NatExpr : Nat → Expr
+  OperExpr : Char → Expr

 record Result (A : Set) : Set where
  constructor emit
@ -49,6 +48,13 @@ takeCons cs (x ∷ xs) with (findCharIndex x cs)
 ...                                 | emit nothing rem = emit↓ (x ∷ []) xs
 ...                                 | emit (just val) rem = emit↓ (x ∷ val) rem

+takeOnce : List Char → List Char → Result Char
+takeOnce _ [] = emit↑ []
+takeOnce [] r = emit↑ r
+takeOnce cs (x ∷ xs) with (findCharIndex x cs)
+...                     | nothing = emit↑ (x ∷ xs)
+...                     | just n = emit↓ x xs
+
 -- ignore consecutive characters
 ignoreCons : List Char → List Char → List Char
 ignoreCons _ [] = []
@ -93,11 +99,11 @@ parseNat a (x ∷ xs) with parseChar x
 ...                    | Digit n = parseNat (just (((default 0 a) * 10) + n)) xs
 ...                    | _ = emit↑ xs

-takeNat : List Char → Result Nat
+takeNat : List Char → Result Expr
 takeNat s with takeCons digits s
 ...          | emit nothing rem₁ = emit↑ rem₁
 ...          | emit (just xs) rem₁ with parseNat nothing xs
-...                                   | emit (just n) rem₂ = emit↓ n rem₁
+...                                   | emit (just n) rem₂ = emit↓ (NatExpr n) rem₁
 ...                                   | emit _ rem₂ = emit↑ rem₁

 -- provided for completeness with the parse/take pair above, but this one is not used
@ -107,41 +113,53 @@ parseOper (x ∷ xs) with parseChar x
 ...                   | Oper o = emit↓ (Oper o) xs
 ...                   | _ = emit↑ xs

-takeOper : List Char → Result Token
+takeOper : List Char → Result Expr
 takeOper s with takeCons opers s
 ...           | emit nothing rem = emit↑ rem
 ...           | emit (just []) rem = emit↑ rem
 ...           | emit (just (x ∷ xs)) rem with parseChar x
-...                                         | Oper o = emit↓ (Oper o) (xs ++ rem)
+...                                         | Oper o = emit↓ (OperExpr o) (xs ++ rem)
 ...                                         | _ = emit↑ s
+
 -- why doesn't this version work?
 -- ...           | emit (just xs) rem with parseOper xs
 -- ...                                   | emit (just (Oper o)) rem₂ = emit↓ (Oper o) rem₂
 -- ...                                   | emit _ rem₂ = emit↑ rem

-takeAlt : { R : Set } → ( List Char → Result R ) → ( List Char → Result R ) → List Char → Result R
+-- a recursive parser does not structurally terminate, but since the input string is finite
+-- and every take* function consumes some characters, it must eventually exhaust the input
+-- string or run out of alternatives to try

+{-# NON_TERMINATING #-}
+takeAlt : ( List Char → Result Expr ) → ( List Char → Result Expr ) → List Char → Result Expr
+takeBin : List Char → Result Expr
 takeGroup : { G : Set } → ( List Char → Result G ) → List Char → Result G

-takeBin : List Char → Result BinExpr
-takeBin s with (takeAlt takeNat (takeGroup takeNat)) (ignoreCons skips s)
+takeBinGroup = takeAlt (takeGroup takeBin) takeBin
+takeAny = takeAlt takeBinGroup takeNat
+
+takeBin s with takeNat (ignoreCons skips s)
 ...          | emit nothing rem₁ = emit↑ s
 ...          | emit (just res₁) rem₁ with takeOper (ignoreCons skips rem₁)
-...                                     | emit nothing rem₂ = emit↑ rem₁
-...                                     | emit (just oper) rem₂ with (takeAlt takeNat (takeGroup takeNat)) (ignoreCons skips rem₂)
-...                                                                | emit nothing rem₃ = emit↑ rem₁
-...                                                                | emit (just res₃) rem₃ = emit↓ (bin oper (Digit res₁) (Digit res₃)) rem₃
+...                                     | emit nothing rem₂ = emit↑ s
+...                                     | emit (just oper) rem₂ with takeAny (ignoreCons skips rem₂)
+...                                                                | emit nothing rem₃ = emit↑ s
+...                                                                | emit (just res₃) rem₃ = emit↓ (BinExpr oper res₁ res₃) rem₃

-takeGroup f s with takeCons ('(' ∷ []) s
+takeGroup f [] = emit↑ []
+takeGroup f s with takeOnce ('(' ∷ []) s
+...              | emit nothing _ = emit↑ s
 ...              | emit _ rem with f rem
-...                              | emit g rem₂ with takeCons (')' ∷ []) rem₂
-...                                               | emit _ rem₃ = emit g rem₃
+...                              | emit nothing _ = emit↑ s
+...                              | emit (just r) rem₂ with takeOnce (')' ∷ []) rem₂
+...                                               | emit nothing _ = emit↑ s
+...                                               | emit _ rem₃ = emit↓ r rem₃

 takeAlt a b s with a s
-...              | emit (just r) rem = emit↓ r rem
-...              | emit nothing rem with b s
-...                                    | emit (just r) rem = emit↓ r rem
-...                                    | emit nothing rem = emit↑ s
+...              | emit (just r) rem₁ = emit↓ r rem₁
+...              | emit nothing rem₁ with b s
+...                                    | emit (just r) rem₂ = emit↓ r rem₂
+...                                    | emit nothing rem₂ = emit↑ s

-takeLine : List Char → List (Result BinExpr)
-takeLine s = map (takeAlt takeBin (takeGroup takeBin)) (map reverse (reverse (split (';' ∷ []) s)))
+takeLine : List Char → List (Result Expr)
+takeLine s = map takeAny (map reverse (reverse (split (';' ∷ []) s)))
--- a/tests.txt
+++ b/tests.txt
@ -0,0 +1,8 @@
+1+1
+1+2
+10+120
+5-4
+5-8
+2*2
+10/5
+((1+(2+3)))
--- a/typescript/Calc.ts
+++ b/typescript/Calc.ts
@ -1,4 +1,4 @@
-import { evalBin } from './Eval.js';
+import { evalTree } from './Eval.js';
 import { getLine, putStrLn } from './IO.js';
 import { nothing } from './Maybe.js';
 import { takeLine } from './Parse.js';
@ -6,7 +6,7 @@ import { show, showList, showResult } from './Show.js';
 import { map, primStringToList } from './Util.js';

 export function main(): Promise<void> {
-  return getLine().then(c => putStrLn(showList((showResult<number>).bind(nothing(), show), map(evalBin, takeLine(primStringToList(c))))));
+  return getLine().then(c => putStrLn(showList((showResult<number>).bind(nothing(), show), map(evalTree, takeLine(primStringToList(c))))));
 }

 main().catch(err => {
--- a/typescript/Eval.ts
+++ b/typescript/Eval.ts
@ -1,31 +1,40 @@
-import { BinExpr, emitBack, emitCont, isCont, result, Result } from './Parse.js';
+import { emitBack, emitCont, Expr, isCont, Result, result } from './Parse.js';

 /**
 * evaluate a binary expression of the form `Oper o -> Digit a -> Digit b`
 */
-export function evalBin(b: Result<BinExpr>): Result<number> {
+export function evalTree(b: Result<Expr>): Result<number> {
  if (isCont(b)) {
    const br = result(b);

-    if (br.lhs.type === 'digit' && br.oper.type === 'oper' && br.rhs.type === 'digit') {
-      switch (br.oper.val) {
-        case '+':
-          return emitCont(br.lhs.val + br.rhs.val, b.rem);
-        case '-':
-          return emitCont(br.lhs.val - br.rhs.val, b.rem);
-        case '*':
-          return emitCont(br.lhs.val * br.rhs.val, b.rem);
-        case '/':
-          if (br.rhs.val === 0) {
+    if (br.type === 'digit') {
+      return emitCont(br.val, b.rem);
+    }
+
+    if (br.type === 'bin' && br.oper.type === 'oper') {
+      const lhs = evalTree(emitCont(br.lhs, b.rem));
+      const rhs = evalTree(emitCont(br.rhs, b.rem));
+
+      if (isCont(lhs) && isCont(rhs)) {
+        switch (br.oper.val) {
+          case '+':
+            return emitCont(result(lhs) + result(rhs), b.rem);
+          case '-':
+            return emitCont(result(lhs) - result(rhs), b.rem);
+          case '*':
+            return emitCont(result(lhs) * result(rhs), b.rem);
+          case '/':
+            if (result(rhs) === 0) {
+              return emitBack(b.rem);
+            } else {
+              return emitCont(result(lhs) / result(rhs), b.rem);
+            }
+          default:
            return emitBack(b.rem);
-          } else {
-            return emitCont(br.lhs.val / br.rhs.val, b.rem);
-          }
-        default:
-          return emitBack(b.rem);
+        }
      }
    }
  }

  return emitBack(b.rem);
-}
+}
--- a/typescript/Parse.ts
+++ b/typescript/Parse.ts
@ -49,13 +49,17 @@ export function term(): Token {
 }

 export interface BinExpr {
+  type: 'bin';
  oper: Token;
-  lhs: Token;
-  rhs: Token;
+  lhs: Expr;
+  rhs: Expr;
 }

-export function bin(oper: Token, lhs: Token, rhs: Token): BinExpr {
+export type Expr = BinExpr | Token;
+
+export function bin(oper: Token, lhs: Expr, rhs: Expr): BinExpr {
  return {
+    type: 'bin',
    oper,
    lhs,
    rhs,
@ -122,10 +126,16 @@ export function isBack<T>(r: Result<T>): r is Result<T, Nothing> {
  return isNothing(r.res);
 }

+type Parser<T> = (s: ReadonlyArray<string>) => Result<T>;
+
 /**
 * take consecutive characters that match the given character set.
 */
 export function takeCons(cs: ReadonlyArray<string>, xs: ReadonlyArray<string>): Result<ReadonlyArray<string>> {
+  if (cs.length === 0 || xs.length === 0) {
+    return emitBack(xs);
+  }
+
  const acc: Array<string> = [];
  const rem = Array.from(xs);

@ -133,7 +143,24 @@ export function takeCons(cs: ReadonlyArray<string>, xs: ReadonlyArray<string>):
    acc.push(mustExist(rem.shift()));
  }

-  return emitCont(acc, rem)
+  if (acc.length > 0) {
+    return emitCont(acc, rem)
+  }
+
+  return emitBack(xs);
+}
+
+export function takeOnce(cs: ReadonlyArray<string>, xs: ReadonlyArray<string>): Result<string> {
+  if (cs.length === 0 || xs.length === 0) {
+    return emitBack(xs);
+  }
+
+  const [x, ...xr] = xs;
+  if (cs.includes(x)) {
+    return emitCont(x, xr);
+  }
+
+  return emitBack(xs);
 }

 /**
@ -210,14 +237,14 @@ export function parseNat(a: Maybe<number>, cs: ReadonlyArray<string>): Result<nu
 /**
 * attempt to take a natural number from a stream.
 */
-export function takeNat(s: ReadonlyArray<string>): Result<number> {
+export function takeNat(s: ReadonlyArray<string>): Result<Token> {
  const cs = takeCons(DIGITS, s);

  if (isCont(cs)) {
    const n = parseNat(nothing(), result(cs));

    if (isCont(n)) {
-      return emitCont(result(n), remain(cs));
+      return emitCont(digit(result(n)), remain(cs));
    }
  }

@ -252,20 +279,17 @@ export function takeOper(s: ReadonlyArray<string>): Result<Token> {
 /**
 * attempt to take a binary expression from a stream.
 */
-export function takeBin(s: ReadonlyArray<string>): Result<BinExpr> {
-  const takeAltNatGroup: (s: ReadonlyArray<string>) => Result<number> =
-    (takeAlt<number>).bind(nothing(), takeNat, (takeGroup<number>).bind(nothing(), takeNat));
-
-  const lhs = takeAltNatGroup(ignoreCons(SKIPS, s));
+export function takeBin(s: ReadonlyArray<string>): Result<Expr> {
+  const lhs = takeStarter(ignoreCons(SKIPS, s));

  if (isCont(lhs)) {
    const oper = takeOper(ignoreCons(SKIPS, remain(lhs)));

    if (isCont(oper)) {
-      const rhs = takeAltNatGroup(ignoreCons(SKIPS, remain(oper)));
+      const rhs = takeAny(ignoreCons(SKIPS, remain(oper)));

      if (isCont(rhs)) {
-        return emitCont(bin(result(oper), digit(result(lhs)), digit(result(rhs))), remain(rhs));
+        return emitCont(bin(result(oper), result(lhs), result(rhs)), remain(rhs));
      }
    }
  }
@ -273,15 +297,31 @@ export function takeBin(s: ReadonlyArray<string>): Result<BinExpr> {
  return emitBack(s);
 }

-export function takeGroup<T>(f: (s: ReadonlyArray<string>) => Result<T>, s: ReadonlyArray<string>): Result<T> {
-  const a = takeCons(['('], s);
-  const b = f(remain(a));
-  const c = takeCons([')'], remain(b));
+/**
+ * attempt to take a rule surrounded by parenthesis.
+ */
+export function takeGroup<T>(f: Parser<T>, s: ReadonlyArray<string>): Result<T> {
+  const a = takeOnce(['('], s);

-  return emit(b.res, remain(c));
+  if (isCont(a)) {
+    const b = f(remain(a));
+
+    if (isCont(b)) {
+      const c = takeOnce([')'], remain(b));
+
+      if (isCont(c)) {
+        return emit(b.res, remain(c));
+      }
+    }
+  }
+
+  return emitBack(s);
 }

-export function takeAlt<T>(a: (s: ReadonlyArray<string>) => Result<T>, b: (s: ReadonlyArray<string>) => Result<T>, s: ReadonlyArray<string>): Result<T> {
+/**
+ * attempt to take the first rule. if that fails, attempt to take the second.
+ */
+export function takeAlt<TA, TB = TA>(a: Parser<TA>, b: Parser<TB>, s: ReadonlyArray<string>): Result<TA | TB> {
  const ra = a(s);
  if (isCont(ra)) {
    return ra;
@ -298,9 +338,13 @@ export function takeAlt<T>(a: (s: ReadonlyArray<string>) => Result<T>, b: (s: Re
 /**
 * split a string into expressions and parse them
 */
-export function takeLine(c: ReadonlyArray<string>): ReadonlyArray<Result<BinExpr>> {
-  const takeAltBinGroup: (s: ReadonlyArray<string>) => Result<BinExpr> =
-    (takeAlt<BinExpr>).bind(nothing(), takeBin, (takeGroup<BinExpr>).bind(nothing(), takeBin));
-
-  return map(takeAltBinGroup, split([';'], c));
+export function takeLine(c: ReadonlyArray<string>): ReadonlyArray<Result<Expr>> {
+  return map(takeAny, split([';'], c));
 }
+
+export const takeBinGroup: Parser<Expr> = (takeGroup<Expr>).bind(nothing(), takeBin);
+export const takeBinAltGroup: Parser<Expr> = (takeAlt<Expr>).bind(nothing(), takeBinGroup, takeBin);
+export const takeAny: Parser<Expr> = (takeAlt<Expr>).bind(nothing(), takeBinAltGroup, takeNat);
+
+// limit the first half of binary expressions to a group or number, removing the option for an immediately nested bin
+export const takeStarter: Parser<Expr> = (takeAlt<Expr>).bind(nothing(), takeBinGroup, takeNat);
--- a/typescript/Show.ts
+++ b/typescript/Show.ts
@ -20,7 +20,11 @@ export function showList<T>(f: (t: T) => string, arr: ReadonlyArray<T>): string
 */
 export function showResult<T>(f: (t: T) => string, r: Result<T>): string {
  if (isCont(r)) {
-    return 'result: ' + f(result(r));
+    if (r.rem.length > 0) {
+      return `result: ${f(result(r))}, remainder: ${primStringFromList(remain(r))}`;
+    } else {
+      return 'result: ' + f(result(r));
+    }
  } else {
    return 'remainder: ' + primStringFromList(remain(r));
  }
--- a/typescript/Util.ts
+++ b/typescript/Util.ts
@ -1,4 +1,4 @@
-import { mustExist } from './Maybe.js';
+import { mustExist, nothing } from './Maybe.js';

 /**
 * functional wrapper for Array.map
@ -54,4 +54,4 @@ export function primStringToList(s: string): ReadonlyArray<string> {

 export function primStringFromList(s: ReadonlyArray<string>): string {
  return s.join('');
-}
+}