aoc2023/lib/int.quox
2023-12-12 20:37:05 +01:00

149 lines
4.4 KiB
Text
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

load "nat.quox"
namespace int {
def0 Sign : ★ = {pos, neg-succ}
def0 : ★ = Sign ×
def from- : = λ n ⇒ ('pos, n)
def neg- : =
λ n ⇒ case n return of { 0 ⇒ ('pos, 0); succ n ⇒ ('neg-succ, n) }
def zero : = ('pos, 0)
def match : 0.(A : ★) → ω.(pos neg : → A) → → A =
λ A pos neg x ⇒
case x return A of { (s, x) ⇒
case s return A of { 'pos ⇒ pos x; 'neg-succ ⇒ neg x }
}
def negate : =
match neg- (λ x ⇒ from- (succ x))
def minus-- : =
λ m n ⇒
letω f : ω. → ω. = λ m n ⇒
bool.if (nat.ge m n) (from- (nat.minus m n))
(neg- (nat.minus n m)) in
getω (app2ω f (nat.dup m) (nat.dup n))
def plus- : =
match () (λ x n ⇒ from- (nat.plus x n))
(λ x n ⇒ minus-- n (succ x))
def minus- : =
match () minus-- (λ x n ⇒ ('neg-succ, nat.plus x n))
def plus : =
match () (λ x y ⇒ plus- y x) (λ x y ⇒ minus- y (succ x))
def minus : = λ x y ⇒ plus x (negate y)
def dup-sign : Sign → [ω. Sign] =
λ s ⇒ case s return [ω. Sign] of {
'pos ⇒ ['pos];
'neg-succ ⇒ ['neg-succ]
}
def0 dup-sign-ok : (s : Sign) → dup-sign s ≡ [s] : [ω. Sign] =
λ s ⇒ case s return s' ⇒ dup-sign s' ≡ [s'] : [ω. Sign] of {
'pos ⇒ δ 𝑖 ⇒ ['pos];
'neg-succ ⇒ δ 𝑖 ⇒ ['neg-succ]
}
def dup : → [ω.] =
λ x ⇒ case x return [ω.] of { (s, n) ⇒
app2ω Sign (λ s n ⇒ (s, n)) (dup-sign s) (nat.dup n)
}
def0 dup-ok : (x : ) → dup x ≡ [x] : [ω.] =
λ x ⇒
case x return x' ⇒ dup x' ≡ [x'] : [ω.] of { (s, n) ⇒ δ 𝑖
app2ω Sign (λ s n ⇒ (s, n)) (dup-sign-ok s @𝑖) (nat.dup-ok n @𝑖)
}
def times- : =
match ()
(λ m n ⇒ from- (nat.times m n))
(λ m' n ⇒ neg- (nat.times (succ m') n))
def times : =
match () (λ p x ⇒ times- x p) (λ n x ⇒ negate (times- x (succ n)))
def abs : = match (λ p ⇒ p) (λ n ⇒ succ n)
def pair-eq? : 0.(A B : ★) → ω.(DecEq A) → ω.(DecEq B) → DecEq (A × B) =
λ A B eqA? eqB? x y ⇒
let0 Ret : ★ = x ≡ y : (A × B) in
letω a0 = fst x; a1 = fst y;
b0 = snd x; b1 = snd y in
dec.elim (a0 ≡ a1 : A) (λ _ ⇒ Dec Ret)
(λ ya ⇒
dec.elim (b0 ≡ b1 : B) (λ _ ⇒ Dec Ret)
(λ yb ⇒ Yes Ret (δ 𝑖 ⇒ (ya @𝑖, yb @𝑖)))
(λ nb ⇒ No Ret (λ eq ⇒ nb (δ 𝑖 ⇒ snd (eq @𝑖))))
(eqB? b0 b1))
(λ na ⇒ No Ret (λ eq ⇒ na (δ 𝑖 ⇒ fst (eq @𝑖))))
(eqA? a0 a1)
def sign-eq? : DecEq Sign =
λ x y ⇒
let0 disc : Sign → ★ =
λ s ⇒ case s return ★ of { 'pos ⇒ True; 'neg-succ ⇒ False } in
case x return x' ⇒ Dec (x' ≡ y : Sign) of {
'pos ⇒
case y return y' ⇒ Dec ('pos ≡ y' : Sign) of {
'pos ⇒ dec.yes-refl Sign 'pos;
'neg-succ ⇒
No ('pos ≡ 'neg-succ : Sign)
(λ eq ⇒ coe (𝑖 ⇒ disc (eq @𝑖)) 'true)
};
'neg-succ ⇒
case y return y' ⇒ Dec ('neg-succ ≡ y' : Sign) of {
'neg-succ ⇒ dec.yes-refl Sign 'neg-succ;
'pos ⇒
No ('neg-succ ≡ 'pos : Sign)
(λ eq ⇒ coe (𝑖 ⇒ disc (eq @𝑖)) @1 @0 'true)
}
}
#[compile-scheme "(lambda% (x y) (if (equal? x y) Yes No))"]
def eq? : DecEq = pair-eq? Sign sign-eq? nat.eq?
def eq : ω. → ω. → Bool =
λ x y ⇒ dec.bool (x ≡ y : ) (eq? x y)
}
def0 = int.
namespace scheme-int {
postulate0 Int : ★
#[compile-scheme "(lambda (x) x)"]
postulate from- : → Int
#[compile-scheme "(lambda% (x y) (+ x y))"]
postulate plus : Int → Int → Int
#[compile-scheme "(lambda% (x y) (- x y))"]
postulate minus : Int → Int → Int
#[compile-scheme "(lambda% (x y) (* x y))"]
postulate times : Int → Int → Int
#[compile-scheme "(lambda% (x y) (if (= x y) 'true 'false))"]
postulate eq : Int → Int → Bool
#[compile-scheme "abs"]
postulate abs : Int →
}