||| Primitive operations for fixed size, unsigned integers.
module Primitives.UInt

import Primitives.Common
import Core.Context
import CairoCode.CairoCode
import Data.SortedSet
import Data.SortedMap
import CommonDef
import CodeGen.CodeGenHelper

---------------------------------------------------------------------------------------------------
-- UINT ADD
---------------------------------------------------------------------------------------------------
add_uintX_name : Nat -> Name
add_uintX_name nBits = makeBuiltinName "add_uint\{show nBits}"

add_uintX_code : Name -> Nat -> String
add_uintX_code name nBits = """
    # Adds two uints
    # Returns the result as a uint
    func \{cairoName name}(range_check_ptr, a : felt, b : felt) -> (res : felt, range_check_ptr):
        alloc_locals
        local res : felt
        local carry : felt
        %{ (ids.carry, ids.res) = divmod(ids.a + ids.b, \{show shift}) %}

        assert carry * carry = carry  # carry is 0 or 1
        assert res = a + b - carry * \{show shift}

        # inlined uint_check(res)
        assert [range_check_ptr] = res
        assert [range_check_ptr+1] = \{show (shift - 1)} - res
        let range_check_ptr = range_check_ptr+2

        return (res, range_check_ptr)
    end
"""
  where shift : Integer
        shift = pow2 nBits

add_uintX : Nat -> (Name, Lazy CairoDef)
add_uintX nBits = (name, def)
  where name : Name
        name = add_uintX_name nBits
        def : CairoDef
        def = ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty (add_uintX_code name nBits)) 2 1

export
[add_uint8] PrimFn where
    eval [_, ConstValue (B8 0)] = Just $ ArgValue 0
    eval [ConstValue (B8 0), _] = Just $ ArgValue 1
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ B8 (a+b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [add_uintX 8]
    generateCode res args implicits = Instructions [CALL [res] implicits (add_uintX_name 8) args]

export
[add_uint16] PrimFn where
    eval [_, ConstValue (B16 0)] = Just $ ArgValue 0
    eval [ConstValue (B16 0), _] = Just $ ArgValue 1
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ B16 (a+b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [add_uintX 16]
    generateCode res args implicits = Instructions [CALL [res] implicits (add_uintX_name 16) args]

export
[add_uint32] PrimFn where
    eval [_, ConstValue (B32 0)] = Just $ ArgValue 0
    eval [ConstValue (B32 0), _] = Just $ ArgValue 1
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ B32 (a+b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [add_uintX 32]
    generateCode res args implicits = Instructions [CALL [res] implicits (add_uintX_name 32) args]

export
[add_uint64] PrimFn where
    eval [_, ConstValue (B64 0)] = Just $ ArgValue 0
    eval [ConstValue (B64 0), _] = Just $ ArgValue 1
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ B64 (a+b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [add_uintX 64]
    generateCode res args implicits = Instructions [CALL [res] implicits (add_uintX_name 64) args]

---------------------------------------------------------------------------------------------------
-- UINT SUB
---------------------------------------------------------------------------------------------------
sub_uintX_name : Nat -> Name
sub_uintX_name nBits = makeBuiltinName "sub_uint\{show nBits}"

sub_uintX_code : Name -> Nat -> String
sub_uintX_code name nBits = """
    # Subtracts two integers.
    # Returns the result as a uint.
    func \{cairoName name}(range_check_ptr, a : felt, b : felt) -> (res : felt, range_check_ptr):
        alloc_locals
        local res : felt
        local borrow : felt
        %{
            (carry, ids.res) = divmod(ids.a - ids.b, \{show shift})
            ids.borrow = -carry  # if b > a then carry is -1
        %}

        assert borrow * borrow = borrow  # borrow is 0 or 1
        assert res = a - b + borrow * \{show shift}
        # inlined uint_check(res)
        assert [range_check_ptr] = res
        assert [range_check_ptr+1] = \{show (shift - 1)} - res
        let range_check_ptr = range_check_ptr+2

        return (res, range_check_ptr)
    end
"""
  where shift : Integer
        shift = pow2 nBits

sub_uintX : Nat -> (Name, Lazy CairoDef)
sub_uintX nBits = (name, def)
  where name : Name
        name = sub_uintX_name nBits
        def : CairoDef
        def = ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty (sub_uintX_code name nBits)) 2 1

export
[sub_uint8] PrimFn where
    eval [_, ConstValue (B8 0)] = Just $ ArgValue 0
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ B8 (a-b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [sub_uintX 8]
    generateCode res args implicits = Instructions [CALL [res] implicits (sub_uintX_name 8) args]

export
[sub_uint16] PrimFn where
    eval [_, ConstValue (B16 0)] = Just $ ArgValue 0
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ B16 (a-b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [sub_uintX 16]
    generateCode res args implicits = Instructions [CALL [res] implicits (sub_uintX_name 16) args]

export
[sub_uint32] PrimFn where
    eval [_, ConstValue (B32 0)] = Just $ ArgValue 0
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ B32 (a-b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [sub_uintX 32]
    generateCode res args implicits = Instructions [CALL [res] implicits (sub_uintX_name 32) args]

export
[sub_uint64] PrimFn where
    eval [_, ConstValue (B64 0)] = Just $ ArgValue 0
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ B64 (a-b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [sub_uintX 64]
    generateCode res args implicits = Instructions [CALL [res] implicits (sub_uintX_name 64) args]

---------------------------------------------------------------------------------------------------
-- UINT MUL
---------------------------------------------------------------------------------------------------
mul_uintX_name : Nat -> Name
mul_uintX_name nBits = makeBuiltinName "mul_uint\{show nBits}"

mul_uintX_code : Name -> Nat -> String
mul_uintX_code name nBits = """
    # Multiplies two uint.
    # Returns the result
    func \{cairoName name}(range_check_ptr, a : felt, b : felt) -> (res : felt, range_check_ptr):
        alloc_locals
        local res : felt
        local offset : felt
        %{ (ids.offset, ids.res) = divmod(ids.a * ids.b, \{show shift}) %}

        # Check offset can not trigger overflow / underflow
        #  to trigger overflow offset*SHIFT must be negative
        #  to trigger underflow offset*SHIFT must be > PRIME - (SHIFT-1)**2
        #    Note: 2**128 (rangecheck) < PRIME - (SHIFT-1)**2 (e.g: 64 => approx 2**128 < 2**192? - 2**128)
        #    Note: Max needed offset*SHIFT = (SHIFT-1)*(SHIFT-1)- SHIFT = (SHIFT-2)*(SHIFT-1) < SHIFT**2
        #	 Note: for SHIFT = 2 ** 64 => offset*SHIFT < 2**128 ((2**64)**2)
        tempvar realOffset = offset * \{show shift}
        assert [range_check_ptr] = realOffset # is positive & smaller 2**128 (this is exactly range_check semantic)
        assert res = a * b - realOffset

        # inlined uint_check(res)
        assert [range_check_ptr+1] = res
        assert [range_check_ptr+2] = \{show (shift - 1)} - res
        let range_check_ptr = range_check_ptr+3

        return (res, range_check_ptr)
    end
"""
  where shift : Integer
        shift = pow2 nBits

mul_uintX : Nat -> (Name, Lazy CairoDef)
mul_uintX nBits = (name, def)
  where name : Name
        name = mul_uintX_name nBits
        def : CairoDef
        def = ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty (mul_uintX_code name nBits)) 2 1

export
[mul_uint8] PrimFn where
    eval [_, ConstValue (B8 1)] = Just $ ArgValue 0
    eval [ConstValue (B8 1), _] = Just $ ArgValue 1
    eval [_, ConstValue (B8 0)] = Just $ NewValue $ ConstValue $ B8 0
    eval [ConstValue (B8 0), _] = Just $ NewValue $ ConstValue $ B8 0
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ B8 (a*b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [mul_uintX 8]
    generateCode res args implicits = Instructions [CALL [res] implicits (mul_uintX_name 8) args]

export
[mul_uint16] PrimFn where
    eval [_, ConstValue (B16 1)] = Just $ ArgValue 0
    eval [ConstValue (B16 1), _] = Just $ ArgValue 1
    eval [_, ConstValue (B16 0)] = Just $ NewValue $ ConstValue $ B16 0
    eval [ConstValue (B16 0), _] = Just $ NewValue $ ConstValue $ B16 0
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ B16 (a*b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [mul_uintX 16]
    generateCode res args implicits = Instructions [CALL [res] implicits (mul_uintX_name 16) args]

export
[mul_uint32] PrimFn where
    eval [_, ConstValue (B32 1)] = Just $ ArgValue 0
    eval [ConstValue (B32 1), _] = Just $ ArgValue 1
    eval [_, ConstValue (B32 0)] = Just $ NewValue $ ConstValue $ B32 0
    eval [ConstValue (B32 0), _] = Just $ NewValue $ ConstValue $ B32 0
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ B32 (a*b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [mul_uintX 32]
    generateCode res args implicits = Instructions [CALL [res] implicits (mul_uintX_name 32) args]

export
[mul_uint64] PrimFn where
    eval [_, ConstValue (B64 1)] = Just $ ArgValue 0
    eval [ConstValue (B64 1), _] = Just $ ArgValue 1
    eval [_, ConstValue (B64 0)] = Just $ NewValue $ ConstValue $ B64 0
    eval [ConstValue (B64 0), _] = Just $ NewValue $ ConstValue $ B64 0
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ B64 (a*b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [mul_uintX 64]
    generateCode res args implicits = Instructions [CALL [res] implicits (mul_uintX_name 64) args]

---------------------------------------------------------------------------------------------------
-- UINT DIV
---------------------------------------------------------------------------------------------------
div_uintX_name : Nat -> Name
div_uintX_name nBits = makeBuiltinName "div_uint\{show nBits}"

div_uintX_code : Name -> Nat -> String
div_uintX_code name nBits = """
    # Division between uint.
    # Returns the quotient.
    # Conforms to Idris specifications: division by 0 yields error.
    func \{cairoName name}(range_check_ptr, a : felt, b : felt) -> (quotient : felt, range_check_ptr):
        alloc_locals
        local res : felt
        local rem : felt
        #Note fails if b = 0, which is ok as this is expected (Hint can not find a solution)
        # Question: is it ok to fail in hint or is a check with assert 0 =  1 needed
        %{ (ids.res, ids.rem) = divmod(ids.a, ids.b) %}

        # Check res * b + rem can not trigger overflow / underflow
        #  Note: 0 < b < 2**64 -- given by semantics
        #  Note: 0 <= res < 2**64 -- checked by uint_check
        #  Implies: 0 <= res * b < 2**128
        #  Note: 0 < rem < 2**64 -- (must be checked -- as hint can lie)
        #  If we weaken to: 0 < rem < 2**128 (rangecheck)
        #  then still: 0 < res * b + rem < 2**129 < PRIME / 2 (positive numbers)

        assert [range_check_ptr] = rem 				# is positive & smaller 2**128 (this is exactly range_check semantic)
        # Note: will fail if b = 0 which is the expected behaviour
        assert [range_check_ptr+1] = b - rem - 1	# rem < b
        assert res * b + rem = a

        # inlined uint_check(res) -- implied as res must be between 0 and a to pass the checks & a is valid (input)
        # assert [range_check_ptr+2] = res
        # assert [range_check_ptr+3] = \{show (shift - 1)} - res
        let range_check_ptr = range_check_ptr+2

        return (res, range_check_ptr)
    end
"""
  where shift : Integer
        shift = pow2 nBits

div_uintX : Nat -> (Name, Lazy CairoDef)
div_uintX nBits = (name, def)
  where name : Name
        name = div_uintX_name nBits
        def : CairoDef
        def = ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty (div_uintX_code name nBits)) 2 1

export
[div_uint8] PrimFn where
    eval [_, ConstValue (B8 0)] = Just $ Failure "Division by zero is not defined"
    eval [_, ConstValue (B8 1)] = Just $ ArgValue 0
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ B8 (a `div` b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [div_uintX 8]
    generateCode res args implicits = Instructions [CALL [res] implicits (div_uintX_name 8) args]

export
[div_uint16] PrimFn where
    eval [_, ConstValue (B16 0)] = Just $ Failure "Division by zero is not defined"
    eval [_, ConstValue (B16 1)] = Just $ ArgValue 0
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ B16 (a `div` b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [div_uintX 16]
    generateCode res args implicits = Instructions [CALL [res] implicits (div_uintX_name 16) args]

export
[div_uint32] PrimFn where
    eval [_, ConstValue (B32 0)] = Just $ Failure "Division by zero is not defined"
    eval [_, ConstValue (B32 1)] = Just $ ArgValue 0
    eval [ConstValue (B32 a), ConstValue (B32 0)] = Just $ Failure "Division by zero is not defined"
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ B32 (a `div` b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [div_uintX 32]
    generateCode res args implicits = Instructions [CALL [res] implicits (div_uintX_name 32) args]

export
[div_uint64] PrimFn where
    eval [_, ConstValue (B64 0)] = Just $ Failure "Division by zero is not defined"
    eval [_, ConstValue (B64 1)] = Just $ ArgValue 0
    eval [ConstValue (B64 a), ConstValue (B64 0)] = Just $ Failure "Division by zero is not defined"
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ B64 (a `div` b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [div_uintX 64]
    generateCode res args implicits = Instructions [CALL [res] implicits (div_uintX_name 64) args]

---------------------------------------------------------------------------------------------------
-- UINT MOD
---------------------------------------------------------------------------------------------------
mod_uintX_name : Nat -> Name
mod_uintX_name nBits = makeBuiltinName "mod_uint\{show nBits}"

mod_uintX_code : Name -> Nat -> String
mod_uintX_code name nBits = """
    # Division between uint.
    # Returns the remainder.
    # Conforms to Idris specifications: division by 0 yields error.
    func \{cairoName name}(range_check_ptr, a : felt, b : felt) -> (remainder : felt, range_check_ptr):
        alloc_locals
        local res : felt
        local rem : felt
        #Note fails if b = 0, which is ok as this is expected (Hint can not find a solution)
        # Question: is it ok to fail in hint or is a check with assert 0 =  1 needed
        %{ (ids.res, ids.rem) = divmod(ids.a, ids.b) %}

        # Check res * b + rem can not trigger overflow / underflow
        #  Note: 0 < b < 2**64 -- given by semantics
        #  Note: 0 <= res < 2**64 -- checked by uint_check
        #  Implies: 0 <= res * b < 2**128
        #  Note: 0 < rem < 2**64 -- (must be checked -- as hint can lie)
        #  If we weaken to: 0 < rem < 2**128 (rangecheck)
        #  then still: 0 < res * b + rem < 2**129 < PRIME / 2 (positive numbers)

        assert [range_check_ptr] = rem 				# is positive & smaller 2**128 (this is exactly range_check semantic)
        # Note: will fail if b = 0 which is the expected behaviour
        assert [range_check_ptr+1] = b - rem - 1	# rem < b
        assert res * b + rem = a

        # inlined uint_check(res) -- implied as res must be between 0 and a to pass the checks & a is valid (input)
        # assert [range_check_ptr+2] = res
        # assert [range_check_ptr+3] = \{show (shift - 1)} - res
        let range_check_ptr = range_check_ptr+2

        return (rem, range_check_ptr)
    end
"""
  where shift : Integer
        shift = pow2 nBits

mod_uintX : Nat -> (Name, Lazy CairoDef)
mod_uintX nBits = (name, def)
  where name : Name
        name = mod_uintX_name nBits
        def : CairoDef
        def = ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty (mod_uintX_code name nBits)) 2 1

export
[mod_uint8] PrimFn where
    eval [_, ConstValue (B8 1)] = Just $ NewValue $ ConstValue $ B8 0
    eval [_, ConstValue (B8 0)] = Just $ Failure "Division by zero is not defined"
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ B8 (a `mod` b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [mod_uintX 8]
    generateCode res args implicits = Instructions [CALL [res] implicits (mod_uintX_name 8) args]

export
[mod_uint16] PrimFn where
    eval [_, ConstValue (B16 1)] = Just $ NewValue $ ConstValue $ B16 0
    eval [_, ConstValue (B16 0)] = Just $ Failure "Division by zero is not defined"
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ B16 (a `mod` b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [mod_uintX 16]
    generateCode res args implicits = Instructions [CALL [res] implicits (mod_uintX_name 16) args]

export
[mod_uint32] PrimFn where
    eval [_, ConstValue (B32 1)] = Just $ NewValue $ ConstValue $ B32 0
    eval [_, ConstValue (B32 0)] = Just $ Failure "Division by zero is not defined"
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ B32 (a `mod` b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [mod_uintX 32]
    generateCode res args implicits = Instructions [CALL [res] implicits (mod_uintX_name 32) args]

export
[mod_uint64] PrimFn where
    eval [_, ConstValue (B64 1)] = Just $ NewValue $ ConstValue $ B64 0
    eval [_, ConstValue (B64 0)] = Just $ Failure "Division by zero is not defined"
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ B64 (a `mod` b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [mod_uintX 64]
    generateCode res args implicits = Instructions [CALL [res] implicits (mod_uintX_name 64) args]

---------------------------------------------------------------------------------------------------
-- UINT NEG:
---------------------------------------------------------------------------------------------------
neg_uintX_name : Nat -> Name
neg_uintX_name nBits = makeBuiltinName "neg_uint\{show nBits}"

neg_uintX_code : Name -> Nat -> String
neg_uintX_code name nBits = """
    # Returns -x the negation of x, in the sense that it is that number such that x + -x = 0, if addition wraps around such that 255+1=0.
    # Note that -128 is 128, since 128+128=0.
    func \{cairoName name}(range_check_ptr, b : felt) -> (res : felt, range_check_ptr):
        alloc_locals
        local res : felt
        local borrow : felt
        %{
            (carry, ids.res) = divmod(0 - ids.b, \{show shift})
            ids.borrow = -carry  # if b > 0 then carry is -1
        %}

        assert borrow * borrow = borrow  # borrow is 0 or 1
        assert res = - b + borrow * \{show shift}
        # inlined uint_check(res)
        assert [range_check_ptr] = res
        assert [range_check_ptr+1] = \{show (shift - 1)} - res
        let range_check_ptr = range_check_ptr+2

        return (res, range_check_ptr)
    end
"""
  where shift : Integer
        shift = pow2 nBits

neg_uintX : Nat -> (Name, Lazy CairoDef)
neg_uintX nBits = (name, def)
  where name : Name
        name = neg_uintX_name nBits
        def : CairoDef
        def = ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty (neg_uintX_code name nBits)) 1 1

export
[neg_uint8] PrimFn where
    eval [ConstValue (B8 a)] = Just $ NewValue $ ConstValue $ B8 (-a)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [neg_uintX 8]
    generateCode res args implicits = Instructions [CALL [res] implicits (neg_uintX_name 8) args]

export
[neg_uint16] PrimFn where
    eval [ConstValue (B16 a)] = Just $ NewValue $ ConstValue $ B16 (-a)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [neg_uintX 16]
    generateCode res args implicits = Instructions [CALL [res] implicits (neg_uintX_name 16) args]

export
[neg_uint32] PrimFn where
    eval [ConstValue (B32 a)] = Just $ NewValue $ ConstValue $ B32 (-a)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [neg_uintX 32]
    generateCode res args implicits = Instructions [CALL [res] implicits (neg_uintX_name 32) args]

export
[neg_uint64] PrimFn where
    eval [ConstValue (B64 a)] = Just $ NewValue $ ConstValue $ B64 (-a)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [neg_uintX 64]
    generateCode res args implicits = Instructions [CALL [res] implicits (neg_uintX_name 64) args]

---------------------------------------------------------------------------------------------------
-- UINT SHL
---------------------------------------------------------------------------------------------------
shl_uintX_name : Nat -> Name
shl_uintX_name nBits = makeBuiltinName "shl_uint\{show nBits}"

-- Todo: Analyze complexity of pow and see if a bitpattern based mult is more efficient
shl_uintX_code : Name -> Nat -> String
shl_uintX_code name nBits = """
    # Computes the logical left shift of a uint.
    #  Note: We should consider not supporting these
    #  Reason: Programmers expect them to be quick and often try to optimize by replacing some *,/ with <<, >>
    #          But in cairo these are horrendibly slow
    #		   Inconviniently these are the only one requiring imports and they are the only one that are not ap stable
    func \{cairoName name}(range_check_ptr, a : felt,  b : felt) -> (res : felt, range_check_ptr):

        #inlined uint_pow2
        # If b >= BIT_LENGTH, the result will be zero modulo 2**BIT_LENGTH.
        tempvar res
        %{ids.res = 1 if ids.b < \{show nBits} else 0 %}
        # b < 2**128 & a < 2**128 is given by semantics
        # BIT_LENGTH <= b
        if res == 0:
            assert [range_check_ptr] = b - \{show nBits}
            let range_check_ptr = range_check_ptr + 1
            return (0, range_check_ptr)
        #b < BIT_LENGTH
        else:
            assert [range_check_ptr] = \{show (nBits `minus` 1)} - b
            let range_check_ptr = range_check_ptr + 1
            let (c) = pow{range_check_ptr=range_check_ptr}(2, b)
            \{cairoName (mul_uintX_name nBits)}(range_check_ptr, a, c)
            ret
        end
    end
"""

shl_uintX : Nat -> (Name, Lazy CairoDef)
shl_uintX nBits = (name, def)
  where name : Name
        name = shl_uintX_name nBits
        def : CairoDef
        def = ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty (shl_uintX_code name nBits)) 2 1

shl_uintX_imports : SortedSet Import
shl_uintX_imports = singleton (MkImport "starkware.cairo.common.pow" "pow")

export
[shl_uint8] PrimFn where
    apStable = False

    eval [_, ConstValue(B8 0)] = Just $ ArgValue 0
    eval [ConstValue (B8 a), ConstValue(B8 b)] = Just $ NewValue $ ConstValue $ B8 (prim__shl_Bits8 (cast a) (cast b))
    eval _ = Nothing

    imports = shl_uintX_imports
    implicits = singleton range_check_builtin
    dependencies = fromList [shl_uintX 8, mul_uintX 8]
    generateCode res args implicits = Instructions [CALL [res] implicits (shl_uintX_name 8) args]

export
[shl_uint16] PrimFn where
    apStable = False

    eval [_, ConstValue(B16 0)] = Just $ ArgValue 0
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ B16 (prim__shl_Bits16 (cast a) (cast b))
    eval _ = Nothing

    imports = shl_uintX_imports
    implicits = singleton range_check_builtin
    dependencies = fromList [shl_uintX 16, mul_uintX 16]
    generateCode res args implicits = Instructions [CALL [res] implicits (shl_uintX_name 16) args]

export
[shl_uint32] PrimFn where
    apStable = False

    eval [_, ConstValue(B32 0)] = Just $ ArgValue 0
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ B32 (prim__shl_Bits32 (cast a) (cast b))
    eval _ = Nothing

    imports = shl_uintX_imports
    implicits = singleton range_check_builtin
    dependencies = fromList [shl_uintX 32, mul_uintX 32]
    generateCode res args implicits = Instructions [CALL [res] implicits (shl_uintX_name 32) args]

export
[shl_uint64] PrimFn where
    apStable = False

    eval [_, ConstValue(B64 0)] = Just $ ArgValue 0
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ B64 (prim__shl_Bits64 (cast a) (cast b))
    eval _ = Nothing

    imports = shl_uintX_imports
    implicits = singleton range_check_builtin
    dependencies = fromList [shl_uintX 64, mul_uintX 64]
    generateCode res args implicits = Instructions [CALL [res] implicits (shl_uintX_name 64) args]

---------------------------------------------------------------------------------------------------
-- UINT SHR
---------------------------------------------------------------------------------------------------
shr_uintX_name : Nat -> Name
shr_uintX_name nBits = makeBuiltinName "shr_uint\{show nBits}"

-- Todo: Analyze complexity of pow and see if a bitpattern based div is more efficient
shr_uintX_code : Name -> Nat -> String
shr_uintX_code name nBits = """
    # Computes the logical right shift of a uint.
    #  Reason: Programmers expect them to be quick and often try to optimize by replacing some *,/ with <<, >>
    #          But in cairo these are horrendibly slow
    #		   Inconviniently these are the only one requiring imports and they are the only one that are not ap stable
    func \{cairoName name}(range_check_ptr, a : felt,  b : felt) -> (res : felt, range_check_ptr):
        #inlined uint_pow2
        # If b >= BIT_LENGTH, the result will be zero modulo 2**BIT_LENGTH.
        tempvar res
        %{ids.res = 1 if ids.b < \{show nBits} else 0 %}
        # b < 2**128 & a < 2**128 is given by semantics
        # BIT_LENGTH <= b
        if res == 0:
            assert [range_check_ptr] = b - \{show nBits}
            let range_check_ptr = range_check_ptr + 1
            return (0, range_check_ptr)
        #b < BIT_LENGTH
        else:
            assert [range_check_ptr] = \{show (nBits `minus` 1)} - b
            let range_check_ptr = range_check_ptr + 1
            let (c) = pow{range_check_ptr=range_check_ptr}(2, b)
            \{cairoName (div_uintX_name nBits)}(range_check_ptr, a, c)
            ret
        end
    end
"""

shr_uintX : Nat -> (Name, Lazy CairoDef)
shr_uintX nBits = (name, def)
  where name : Name
        name = shr_uintX_name nBits
        def : CairoDef
        def = ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty (shr_uintX_code name nBits)) 2 1

shr_uintX_imports : SortedSet Import
shr_uintX_imports = singleton (MkImport "starkware.cairo.common.pow" "pow")

export
[shr_uint8] PrimFn where
    apStable = False

    eval [_, ConstValue(B8 0)] = Just $ ArgValue 0
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ B8 (prim__shr_Bits8 (cast a) (cast b))
    eval _ = Nothing

    imports = shr_uintX_imports
    implicits = singleton range_check_builtin
    dependencies = fromList [shr_uintX 8, div_uintX 8]
    generateCode res args implicits = Instructions [CALL [res] implicits (shr_uintX_name 8) args]

export
[shr_uint16] PrimFn where
    apStable = False

    eval [_, ConstValue(B16 0)] = Just $ ArgValue 0
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ B16 (prim__shr_Bits16 (cast a) (cast b))
    eval _ = Nothing

    imports = shr_uintX_imports
    implicits = singleton range_check_builtin
    dependencies = fromList [shr_uintX 16, div_uintX 16]
    generateCode res args implicits = Instructions [CALL [res] implicits (shr_uintX_name 16) args]

export
[shr_uint32] PrimFn where
    apStable = False

    eval [_, ConstValue(B32 0)] = Just $ ArgValue 0
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ B32 (prim__shr_Bits32 (cast a) (cast b))
    eval _ = Nothing

    imports = shr_uintX_imports
    implicits = singleton range_check_builtin
    dependencies = fromList [shr_uintX 32, div_uintX 32]
    generateCode res args implicits = Instructions [CALL [res] implicits (shr_uintX_name 32) args]

export
[shr_uint64] PrimFn where
    apStable = False

    eval [_, ConstValue(B64 0)] = Just $ ArgValue 0
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ B64 (prim__shr_Bits64 (cast a) (cast b))
    eval _ = Nothing

    imports = shr_uintX_imports
    implicits = singleton range_check_builtin
    dependencies = fromList [shr_uintX 64, div_uintX 64]
    generateCode res args implicits = Instructions [CALL [res] implicits (shr_uintX_name 64) args]

---------------------------------------------------------------------------------------------------
-- UINT AND
{-
func bitwise_and{bitwise_ptr : BitwiseBuiltin*}(x : felt, y : felt) -> (x_and_y : felt):
    bitwise_ptr.x = x
    bitwise_ptr.y = y
    let x_and_y = bitwise_ptr.x_and_y
    let x_xor_y = bitwise_ptr.x_xor_y
    let x_or_y = bitwise_ptr.x_or_y
    let bitwise_ptr = bitwise_ptr + BitwiseBuiltin.SIZE
    return (x_and_y=x_and_y)
end

struct BitwiseBuiltin:
    member x : felt
    member y : felt
    member x_and_y : felt
    member x_xor_y : felt
    member x_or_y : felt
end
-}
---------------------------------------------------------------------------------------------------

and_uintX_code : CairoReg -> CairoReg -> CairoReg -> CairoReg -> CairoReg -> String
and_uintX_code r bitwise_ptr_in bitwise_ptr_out x y = """
    assert [\{compileReg bitwise_ptr_in}] = \{compileReg x}
    assert [\{compileReg bitwise_ptr_in}+1] = \{compileReg y}
    \{ compileRegDecl bitwise_ptr_out} = \{compileReg bitwise_ptr_in} + BitwiseBuiltin.SIZE
    \{ compileRegDecl r } = [\{compileReg bitwise_ptr_in}+2]

"""

and_uintX : Nat -> CairoReg -> List CairoReg -> LinearImplicitArgs -> PrimFnCode
and_uintX _ res [a,b] implicits =
  case lookup bitwise_builtin implicits of
        Just (bw_in, bw_out) => Raw $ and_uintX_code res bw_in bw_out a b
        Nothing => assert_total $ idris_crash "bitwise_ptr not found"
and_uintX nBits _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode and_uint\{show nBits}"

export
[and_uint8] PrimFn where
    eval [_, ConstValue (B8 0)] = Just $ NewValue $ ConstValue $ B8 0
    eval [ConstValue (B8 0), _] = Just $ NewValue $ ConstValue $ B8 0
    eval [_, ConstValue (B8 255)] = Just $ ArgValue 0
    eval [ConstValue (B8 255), _] = Just $ ArgValue 1
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ B8 (prim__and_Bits8 (cast a) (cast b))
    eval _ = Nothing

    imports = singleton $ bitwiseBuiltinImport
    implicits = singleton bitwise_builtin
    generateCode = and_uintX 8

export
[and_uint16] PrimFn where
    eval [_, ConstValue (B16 0)] = Just $ NewValue $ ConstValue $ B16 0
    eval [ConstValue (B16 0), _] = Just $ NewValue $ ConstValue $ B16 0
    eval [_, ConstValue (B16 65535)] = Just $ ArgValue 0
    eval [ConstValue (B16 65535), _] = Just $ ArgValue 1
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ B16 (prim__and_Bits16 (cast a) (cast b))
    eval _ = Nothing

    imports = singleton $ bitwiseBuiltinImport
    implicits = singleton bitwise_builtin
    generateCode = and_uintX 16

export
[and_uint32] PrimFn where
    eval [_, ConstValue (B32 0)] = Just $ NewValue $ ConstValue $ B32 0
    eval [ConstValue (B32 0), _] = Just $ NewValue $ ConstValue $ B32 0
    eval [_, ConstValue (B32 4294967295)] = Just $ ArgValue 0
    eval [ConstValue (B32 4294967295), _] = Just $ ArgValue 1
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ B32 (prim__and_Bits32 (cast a) (cast b))
    eval _ = Nothing

    imports = singleton $ bitwiseBuiltinImport
    implicits = singleton bitwise_builtin
    generateCode = and_uintX 32

export
[and_uint64] PrimFn where
    eval [_, ConstValue (B64 0)] = Just $ NewValue $ ConstValue $ B64 0
    eval [ConstValue (B64 0), _] = Just $ NewValue $ ConstValue $ B64 0
    eval [_, ConstValue (B64 18446744073709551615)] = Just $ ArgValue 0
    eval [ConstValue (B64 18446744073709551615), _] = Just $ ArgValue 1
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ B64 (prim__and_Bits64 (cast a) (cast b))
    eval _ = Nothing

    imports = singleton $ bitwiseBuiltinImport
    implicits = singleton bitwise_builtin
    generateCode = and_uintX 64

---------------------------------------------------------------------------------------------------
-- UINT OR
---------------------------------------------------------------------------------------------------
or_uintX_code : CairoReg -> CairoReg -> CairoReg -> CairoReg -> CairoReg -> String
or_uintX_code r bitwise_ptr_in bitwise_ptr_out x y = """
    assert [\{compileReg bitwise_ptr_in}] = \{compileReg x}
    assert [\{compileReg bitwise_ptr_in}+1] = \{compileReg y}
    \{ compileRegDecl bitwise_ptr_out} = \{compileReg bitwise_ptr_in} + BitwiseBuiltin.SIZE
    \{ compileRegDecl r } = [\{compileReg bitwise_ptr_in}+4]

"""

or_uintX : Nat -> CairoReg -> List CairoReg -> LinearImplicitArgs -> PrimFnCode
or_uintX _ res [a,b] implicits =
  case lookup bitwise_builtin implicits of
        Just (bw_in, bw_out) => Raw $ or_uintX_code res bw_in bw_out a b
        Nothing => assert_total $ idris_crash "bitwise_ptr not found"
or_uintX nBits _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode or_uint\{show nBits}"

export
[or_uint8] PrimFn where
    eval [_, ConstValue (B8 0)] = Just $ ArgValue 0
    eval [ConstValue (B8 0), _] = Just $ ArgValue 1
    eval [_, ConstValue (B8 255)] = Just $ NewValue $ ConstValue $ B8 255
    eval [ConstValue (B8 255), _] = Just $ NewValue $ ConstValue $ B8 255
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ B8 (prim__or_Bits8 (cast a) (cast b))
    eval _ = Nothing

    imports = singleton $ bitwiseBuiltinImport
    implicits = singleton bitwise_builtin
    generateCode = or_uintX 8

export
[or_uint16] PrimFn where
    eval [_, ConstValue (B16 0)] = Just $ ArgValue 0
    eval [ConstValue (B16 0), _] = Just $ ArgValue 1
    eval [_, ConstValue (B16 65535)] = Just $ NewValue $ ConstValue $ B16 65535
    eval [ConstValue (B16 65535), _] = Just $ NewValue $ ConstValue $ B16 65535
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ B16 (prim__or_Bits16 (cast a) (cast b))
    eval _ = Nothing

    imports = singleton $ bitwiseBuiltinImport
    implicits = singleton bitwise_builtin
    generateCode = or_uintX 16

export
[or_uint32] PrimFn where
    eval [_, ConstValue (B32 0)] = Just $ ArgValue 0
    eval [ConstValue (B32 0), _] = Just $ ArgValue 1
    eval [_, ConstValue (B32 4294967295)] = Just $ NewValue $ ConstValue $ B32 4294967295
    eval [ConstValue (B32 4294967295), _] = Just $ NewValue $ ConstValue $ B32 4294967295
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ B32 (prim__or_Bits32 (cast a) (cast b))
    eval _ = Nothing

    imports = singleton $ bitwiseBuiltinImport
    implicits = singleton bitwise_builtin
    generateCode = or_uintX 32

export
[or_uint64] PrimFn where
    eval [_, ConstValue (B64 0)] = Just $ ArgValue 0
    eval [ConstValue (B64 0), _] = Just $ ArgValue 1
    eval [_, ConstValue (B64 18446744073709551615)] = Just $ NewValue $ ConstValue $ B64 18446744073709551615
    eval [ConstValue (B64 18446744073709551615), _] = Just $ NewValue $ ConstValue $ B64 18446744073709551615
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ B64 (prim__or_Bits64 (cast a) (cast b))
    eval _ = Nothing

    imports = singleton $ bitwiseBuiltinImport
    implicits = singleton bitwise_builtin
    generateCode = or_uintX 64

---------------------------------------------------------------------------------------------------
-- UINT XOR
---------------------------------------------------------------------------------------------------
xor_uintX_code : CairoReg -> CairoReg -> CairoReg -> CairoReg -> CairoReg -> String
xor_uintX_code r bitwise_ptr_in bitwise_ptr_out x y = """
    assert [\{compileReg bitwise_ptr_in}] = \{compileReg x}
    assert [\{compileReg bitwise_ptr_in}+1] = \{compileReg y}
    \{ compileRegDecl bitwise_ptr_out} = \{compileReg bitwise_ptr_in} + BitwiseBuiltin.SIZE
    \{ compileRegDecl r } = [\{compileReg bitwise_ptr_in}+3]

"""

xor_uintX : Nat -> CairoReg -> List CairoReg -> LinearImplicitArgs -> PrimFnCode
xor_uintX _ res [a,b] implicits =
  case lookup bitwise_builtin implicits of
        Just (bw_in, bw_out) => Raw $ xor_uintX_code res bw_in bw_out a b
        Nothing => assert_total $ idris_crash "bitwise_ptr not found"
xor_uintX nBits _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode xor_uint\{show nBits}"

export
[xor_uint8] PrimFn where
    eval [_, ConstValue (B8 0)] = Just $ ArgValue 0
    eval [ConstValue (B8 0), _] = Just $ ArgValue 1
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ B8 (prim__xor_Bits8 (cast a) (cast b))
    eval _ = Nothing

    imports = singleton $ bitwiseBuiltinImport
    implicits = singleton bitwise_builtin
    generateCode = xor_uintX 8

export
[xor_uint16] PrimFn where
    eval [_, ConstValue (B16 0)] = Just $ ArgValue 0
    eval [ConstValue (B16 0), _] = Just $ ArgValue 1
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ B16 (prim__xor_Bits16 (cast a) (cast b))
    eval _ = Nothing

    imports = singleton $ bitwiseBuiltinImport
    implicits = singleton bitwise_builtin
    generateCode = xor_uintX 16

export
[xor_uint32] PrimFn where
    eval [_, ConstValue (B32 0)] = Just $ ArgValue 0
    eval [ConstValue (B32 0), _] = Just $ ArgValue 1
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ B32 (prim__xor_Bits32 (cast a) (cast b))
    eval _ = Nothing

    imports = singleton $ bitwiseBuiltinImport
    implicits = singleton bitwise_builtin
    generateCode = xor_uintX 32

export
[xor_uint64] PrimFn where
    eval [_, ConstValue (B64 0)] = Just $ ArgValue 0
    eval [ConstValue (B64 0), _] = Just $ ArgValue 1
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ B64 (prim__xor_Bits64 (cast a) (cast b))
    eval _ = Nothing

    imports = singleton $ bitwiseBuiltinImport
    implicits = singleton bitwise_builtin
    generateCode = xor_uintX 64

---------------------------------------------------------------------------------------------------
-- UINT LT
---------------------------------------------------------------------------------------------------
lt_uintX_name : Name
lt_uintX_name = makeBuiltinName "lt_uint"

lt_uintX_code : Name -> String
lt_uintX_code name = """
    # Returns 1 if the first unsigned integer is less than the second unsigned integer, otherwise returns 0.
    func \{cairoName name}(range_check_ptr, a : felt, b : felt) -> (res, range_check_ptr):
        tempvar res
        %{ids.res = 1 if ids.a < ids.b else 0 %}
        # b < 2**128 & a < 2**128 is given by semantics
        # b <= a
        if res == 0:
            assert [range_check_ptr] = a - b - 0 # - 0 is for ap stability improves worse case in code gen
            let range_check_ptr = range_check_ptr + 1
            return (0, range_check_ptr)
        #a < b
        else:
            assert [range_check_ptr] = b - a - 1
            let range_check_ptr = range_check_ptr + 1
            return (1, range_check_ptr)
        end
    end
"""

lt_uintX : (Name, Lazy CairoDef)
lt_uintX = (lt_uintX_name, def)
  where def : CairoDef
        def = ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty (lt_uintX_code lt_uintX_name)) 2 1

generateLtCallCode : CairoReg -> List CairoReg -> LinearImplicitArgs -> PrimFnCode
generateLtCallCode res args implicits = Instructions [CALL [res] implicits lt_uintX_name args]

export
[lt_uint8] PrimFn where
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ toInt (a<b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lt_uintX]
    generateCode = generateLtCallCode

export
[lt_uint16] PrimFn where
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ toInt (a<b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lt_uintX]
    generateCode = generateLtCallCode

export
[lt_uint32] PrimFn where
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ toInt (a<b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lt_uintX]
    generateCode = generateLtCallCode

export
[lt_uint64] PrimFn where
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ toInt (a<b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lt_uintX]
    generateCode = generateLtCallCode

---------------------------------------------------------------------------------------------------
-- UINT LTE
---------------------------------------------------------------------------------------------------
lte_uintX_name : Name
lte_uintX_name = makeBuiltinName "lte_uint"

lte_uintX_code : Name -> String
lte_uintX_code name = """
    # Returns 1 if the first unsigned integer is less than or equal to the second unsigned integer, otherwise returns 0.
    func \{cairoName name}(range_check_ptr, a : felt, b : felt) -> (res, range_check_ptr):
        tempvar res
        %{ids.res = 1 if ids.a <= ids.b else 0 %}
        # b < 2**128 & a < 2**128 is given by semantics
        # b < a
        if res == 0:
            assert [range_check_ptr] = a - b - 1
            let range_check_ptr = range_check_ptr + 1
            return (0, range_check_ptr)
        #a <= b
        else:
            assert [range_check_ptr] = b - a - 0	#+0 is for ap stability improves worse case in code gen
            let range_check_ptr = range_check_ptr + 1
            return (1, range_check_ptr)
        end
    end
"""

lte_uintX : (Name, Lazy CairoDef)
lte_uintX = (lte_uintX_name, def)
  where def : CairoDef
        def = ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty (lte_uintX_code lte_uintX_name)) 2 1

generateLteCallCode : CairoReg -> List CairoReg -> LinearImplicitArgs -> PrimFnCode
generateLteCallCode res args implicits = Instructions [CALL [res] implicits lte_uintX_name args]

export
[lte_uint8] PrimFn where
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ toInt (a<=b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lte_uintX]
    generateCode = generateLteCallCode

export
[lte_uint16] PrimFn where
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ toInt (a<=b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lte_uintX]
    generateCode = generateLteCallCode

export
[lte_uint32] PrimFn where
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ toInt (a<=b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lte_uintX]
    generateCode = generateLteCallCode

export
[lte_uint64] PrimFn where
    eval [ ConstValue (B64 a),  ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ toInt (a<=b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lte_uintX]
    generateCode = generateLteCallCode

---------------------------------------------------------------------------------------------------
-- UINT EQ
---------------------------------------------------------------------------------------------------
export
[eq_uint8] PrimFn where
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ toInt (a==b)
    eval _ = Nothing

    generateCode r a i = Raw $ compileEqOp "eq_uint8" r a i

export
[eq_uint16] PrimFn where
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ toInt (a==b)
    eval _ = Nothing

    generateCode r a i = Raw $ compileEqOp "eq_uint16" r a i

export
[eq_uint32] PrimFn where
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ toInt (a==b)
    eval _ = Nothing

    generateCode r a i = Raw $ compileEqOp "eq_uint32" r a i

export
[eq_uint64] PrimFn where
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ toInt (a==b)
    eval _ = Nothing

    generateCode r a i = Raw $ compileEqOp "eq_uint64" r a i

---------------------------------------------------------------------------------------------------
-- UINT GTE
-- Implementation uses flipped arguments to lte
---------------------------------------------------------------------------------------------------

generateGteCallCode : CairoReg -> List CairoReg -> LinearImplicitArgs -> PrimFnCode
generateGteCallCode res [a,b] implicits = Instructions [CALL [res] implicits lte_uintX_name [b,a]] -- Flipped arguments
generateGteCallCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode gte_uintX"

export
[gte_uint8] PrimFn where
    eval [ConstValue (B8 a), ConstValue (B8 b)] = Just $ NewValue $ ConstValue $ toInt (a>=b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lte_uintX]
    generateCode = generateGteCallCode

export
[gte_uint16] PrimFn where
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ toInt (a>=b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lte_uintX]
    generateCode = generateGteCallCode

export
[gte_uint32] PrimFn where
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ toInt (a>=b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lte_uintX]
    generateCode = generateGteCallCode

export
[gte_uint64] PrimFn where
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ toInt (a>=b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lte_uintX]
    generateCode = generateGteCallCode

---------------------------------------------------------------------------------------------------
-- UINT GT
-- Implementation uses flipped arguments to lt
---------------------------------------------------------------------------------------------------

generateGtCallCode : CairoReg -> List CairoReg -> LinearImplicitArgs -> PrimFnCode
generateGtCallCode res [a,b] implicits = Instructions [CALL [res] implicits lt_uintX_name [b,a]] -- Flipped arguments
generateGtCallCode _ _ _ = assert_total $ idris_crash "Bad arguments to generateCode gt_uintX"

export
[gt_uint8] PrimFn where
    eval [ConstValue (B8 a), ConstValue (B8 b)] =Just $ NewValue $ ConstValue $ toInt (a>b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lt_uintX]
    generateCode = generateGtCallCode

export
[gt_uint16] PrimFn where
    eval [ConstValue (B16 a), ConstValue (B16 b)] = Just $ NewValue $ ConstValue $ toInt (a>b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lt_uintX]
    generateCode = generateGtCallCode

export
[gt_uint32] PrimFn where
    eval [ConstValue (B32 a), ConstValue (B32 b)] = Just $ NewValue $ ConstValue $ toInt (a>b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lt_uintX]
    generateCode = generateGtCallCode

export
[gt_uint64] PrimFn where
    eval [ConstValue (B64 a), ConstValue (B64 b)] = Just $ NewValue $ ConstValue $ toInt (a>b)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [lt_uintX]
    generateCode = generateGtCallCode

---------------------------------------------------------------------------------------------------
-- UINT CAST
---------------------------------------------------------------------------------------------------
cast_uintX_name : Nat -> Name
cast_uintX_name nBits = makeBuiltinName "cast_uint\{show nBits}"

cast_uintX_code : Name -> Nat -> String
cast_uintX_code name nBits = """
    # Casts to uint\{show nBits}
    # Returns the result as uint\{show nBits}.
    func \{cairoName name}(range_check_ptr, a : felt) -> (res : felt, range_check_ptr):
        alloc_locals
        local res : felt
        local offset : felt
        %{ (ids.offset, ids.res) = divmod(ids.a, \{show shift}) %}

        # Check offset can not trigger overflow / underflow
        #  to trigger overflow offset*SHIFT must be negative
        #  to trigger underflow offset*SHIFT must be > PRIME - (SHIFT-1)**2
        #    Note: 2**128 (rangecheck) < PRIME - (SHIFT-1)**2 (e.g: 64 => approx 2**128 < 2**192? - 2**128)
        #    Note: Max needed offset*SHIFT = (SHIFT-1)*(SHIFT-1)- SHIFT = (SHIFT-2)*(SHIFT-1) < SHIFT**2
        #	 Note: for SHIFT = 2 ** 64 => offset*SHIFT < 2**128 ((2**64)**2)
        tempvar realOffset = offset * \{show shift}
        assert [range_check_ptr] = realOffset # is positive & smaller 2**128 (this is exactly range_check semantic)
        assert res = a - realOffset

        # inlined uint_check(res)
        assert [range_check_ptr+1] = res
        assert [range_check_ptr+2] = \{show (shift - 1)} - res
        let range_check_ptr = range_check_ptr+3

        return (res, range_check_ptr)
    end
"""
  where shift : Integer
        shift = pow2 nBits

cast_uintX : Nat -> (Name, Lazy CairoDef)
cast_uintX nBits = (name, def)
  where name : Name
        name = cast_uintX_name nBits
        def : CairoDef
        def = ForeignDef (MkForeignInfo True Nothing [range_check_builtin] empty (cast_uintX_code name nBits)) 1 1

export
[cast_to_uint8] PrimFn where
    eval [ConstValue c] = map (\i => NewValue $ ConstValue $ B8 $ cast i) (constToInteger c)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [cast_uintX 8]
    generateCode res args implicits = Instructions [CALL [res] implicits (cast_uintX_name 8) args]

export
[cast_to_uint16] PrimFn where
    eval [ConstValue c] = map (\i => NewValue $ ConstValue $ B16 $ cast i) (constToInteger c)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [cast_uintX 16]
    generateCode res args implicits = Instructions [CALL [res] implicits (cast_uintX_name 16) args]

export
[cast_to_uint32] PrimFn where
    eval [ConstValue c] = map (\i => NewValue $ ConstValue $ B32 $ cast i) (constToInteger c)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [cast_uintX 32]
    generateCode res args implicits = Instructions [CALL [res] implicits (cast_uintX_name 32) args]

export
[cast_to_uint64] PrimFn where
    eval [ConstValue c] = map (\i => NewValue $ ConstValue $ B64 $ cast i) (constToInteger c)
    eval _ = Nothing

    implicits = singleton range_check_builtin
    dependencies = fromList [cast_uintX 64]
    generateCode res args implicits = Instructions [CALL [res] implicits (cast_uintX_name 64) args]


||| Format decimal number into string.
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Text.Format.Digits

import Data.Nat
import Data.Fin
import Data.Primitives.Views

%default total

-- --------------------------------------------------------------------------

public export Digits : (base:Nat) -> Type
Digits base = (n:Int) -> {auto ok:n >= 0 && n < (cast base) = True} -> Char

upperHexdigit : Digits 16
upperHexdigit 0 = '0'
upperHexdigit 1 = '1'
upperHexdigit 2 = '2'
upperHexdigit 3 = '3'
upperHexdigit 4 = '4'
upperHexdigit 5 = '5'
upperHexdigit 6 = '6'
upperHexdigit 7 = '7'
upperHexdigit 8 = '8'
upperHexdigit 9 = '9'
upperHexdigit 10 = 'A'
upperHexdigit 11 = 'B'
upperHexdigit 12 = 'C'
upperHexdigit 13 = 'D'
upperHexdigit 14 = 'E'
upperHexdigit 15 = 'F'
upperHexdigit _ = '_' -- why i need this?

lowerHexdigit : Digits 16
lowerHexdigit 0 = '0'
lowerHexdigit 1 = '1'
lowerHexdigit 2 = '2'
lowerHexdigit 3 = '3'
lowerHexdigit 4 = '4'
lowerHexdigit 5 = '5'
lowerHexdigit 6 = '6'
lowerHexdigit 7 = '7'
lowerHexdigit 8 = '8'
lowerHexdigit 9 = '9'
lowerHexdigit 10 = 'a'
lowerHexdigit 11 = 'b'
lowerHexdigit 12 = 'c'
lowerHexdigit 13 = 'd'
lowerHexdigit 14 = 'e'
lowerHexdigit 15 = 'f'
lowerHexdigit _ = '_'  -- also this

intToDigits : (base:Nat)
            -> {base':Nat} -> {auto ok:base <= base' = True} -> Digits base'
            -> Int -> String
intToDigits base digits n = if n < 0 then pack $ go n [] else "0"
  where
    base_i : Int
    base_i = cast base

    go : Int -> List Char -> List Char
    go 0 xs = xs
    go m xs with (m `divides` base_i)
      go (_ * d + r) xs | DivBy d r prf =
        let prf' = believe_me prf
            in go (assert_smaller n d) (digits {ok=prf'} r :: xs)

-- --------------------------------------------------------------------------

public export DigitNum : (base:Nat) -> Type
DigitNum base = Char -> Maybe Int

hexNum : DigitNum 16
hexNum '0' = Just 0
hexNum '1' = Just 1
hexNum '2' = Just 2
hexNum '3' = Just 3
hexNum '4' = Just 4
hexNum '5' = Just 5
hexNum '6' = Just 6
hexNum '7' = Just 7
hexNum '8' = Just 8
hexNum '9' = Just 9
hexNum 'a' = Just 10
hexNum 'A' = Just 10
hexNum 'b' = Just 11
hexNum 'B' = Just 11
hexNum 'c' = Just 12
hexNum 'C' = Just 12
hexNum 'd' = Just 13
hexNum 'D' = Just 13
hexNum 'e' = Just 14
hexNum 'E' = Just 14
hexNum 'f' = Just 15
hexNum 'F' = Just 15
hexNum _ = Nothing

digitsToInt : (base:Nat)
           -> {base':Nat} -> {auto ok:base <= base' = True} -> Digits base'
           -> String -> Maybe Int
digitsToInt base digits str = go 0 $ unpack str where
  base_i : Int
  base_i = cast base

  go : Int -> List Char -> Maybe Int
  go ans [] = Just ans
  go ans (x::xs) with (hexNum x)
    go ans (x::xs) | Just x' = go (ans * base_i + x') xs
    go ans (x::xs) | Nothing = Nothing

-- --------------------------------------------------------------------------
-- vim: tw=80 sw=2 expandtab :


module Main

import Data.Vect

-- data DataStore: Type -> Type where
--   MkData : (size : Nat) -> (items : Vect size schema) -> DataStore schema

infixr 5 .+.

data Schema = SString
     | SInt
     | (.+.) Schema Schema

SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType (x .+. y) = (SchemaType x, SchemaType y)

data DataStore : Type where
  MkData : (schema : Schema) -> (size : Nat) -> (items  : Vect size (SchemaType schema)) -> DataStore

size : DataStore -> Nat
size (MkData schema' size' items') = size'

schema : DataStore -> Schema
schema (MkData schema' _ _) = schema'

items : (store: DataStore) -> Vect (size store) (SchemaType (schema store))
items (MkData _ _ items') = items'

addToStore : (store: DataStore) -> (SchemaType (schema store)) -> DataStore
addToStore (MkData schema size items) newitem = MkData schema _ (addToData items) where
  addToData : Vect old (SchemaType schema) -> Vect (S old) (SchemaType schema)
  addToData [] = [newitem]
  addToData (x :: xs) = x :: addToData xs

display: SchemaType schema -> String
display {schema = SString} item = show item
display {schema = SInt} item = show item
display {schema = (x .+. y)} (item1, item2) =
  (display item1) ++ ", " ++ (display item2)

parsePrefix : (schema: Schema) -> String -> Maybe (SchemaType schema, String)
parsePrefix SString x = getQuoted (unpack x) where
  getQuoted : List Char -> Maybe (String, String)
  getQuoted ('"':: xs) = case span (/= '"') xs of
    (quoted, '"':: rest) => Just (pack quoted, ltrim (pack rest))
    _ => Nothing
parsePrefix SInt x = case Prelude.Strings.span isDigit x of
  ("", rest) => Nothing
  (num, rest) => Just (cast num, ltrim rest)
parsePrefix (y .+. z) x = do
  (res1, rest) <- parsePrefix y x
  (res2, rest') <- parsePrefix z rest
  pure ((res1, res2), rest')

parseBySchema : (schema: Schema) -> String -> Maybe (SchemaType schema)
parseBySchema schema str = case parsePrefix schema str of
  Just (res, "") => Just res
  Just _ => Nothing
  Nothing => Nothing

getEntry : (pos: Integer) -> (store: DataStore) -> Maybe (String, DataStore)
getEntry pos store = let store_items = items store in
  case integerToFin pos (size store) of
    Nothing => Just ("out of range\n", store)
    Just id => Just (display (index id store_items), store)

data Command : Schema -> Type where
  Add : (SchemaType schema) -> Command schema
  Get : Integer -> Command a
  Quit: Command a

parseCommand : (schema: Schema) -> String -> String -> Maybe (Command schema)
parseCommand schema "add" str = case parseBySchema schema str of
  Just restok => Just (Add restok)
  Nothing => Nothing
parseCommand schema "get" val = case all isDigit (unpack val) of
  False => Nothing
  True => Just (Get (cast val))
parseCommand schema "quit" _ = Just Quit
parseCommand _ _ _ = Just Quit

-- processCommand : Command schema -> DataStore -> Maybe (String, DataStore)
-- processCommand (Add x) ds = Just (?show_size, addToStore ds x)
-- processCommand (Get x) ds = getEntry x ds
-- processCommand Quit _ = Nothing

-- processInput : DataStore -> String -> Maybe (String, DataStore)
-- processInput ds s = case parse s of
--   Nothing => Just ("Invalid command " ++ s ++ "\n", ds)
--   Just command => processCommand command ds


module SudokuSMT

import Data.Vect
import src.SMTLib
import src.Tensor

puzzle :  Tensor [3, 3, 3, 3] Int
puzzle = toTensor
           [ [matrix00, matrix01, matrix02],
             [matrix10, matrix11, matrix12],
             [matrix20, matrix21, matrix22] ]
    where
      matrix00 : Vect 3 (Vect 3 Int)
      matrix00 = [ [5, 3, 0],
                   [6, 0, 0],
                   [0, 9, 8] ]
      matrix01 : Vect 3 (Vect 3 Int)
      matrix01 = [ [0, 7, 0],
                   [1, 9, 5],
                   [0, 0, 0] ]
      matrix02 : Vect 3 (Vect 3 Int)
      matrix02 = [ [0, 0, 0],
                   [0, 0, 0],
                   [0, 6, 0] ]
      matrix10 : Vect 3 (Vect 3 Int)
      matrix10 = [ [8, 0, 0],
                   [4, 0, 0],
                   [7, 0, 0] ]
      matrix11 : Vect 3 (Vect 3 Int)
      matrix11 = [ [0, 6, 0],
                   [8, 0, 3],
                   [0, 2, 0] ]
      matrix12 : Vect 3 (Vect 3 Int)
      matrix12 = [ [0, 0, 3],
                   [0, 0, 1],
                   [0, 0, 6] ]
      matrix20 : Vect 3 (Vect 3 Int)
      matrix20 = [ [0, 6, 0],
                   [0, 0, 0],
                   [0, 0, 0] ]
      matrix21 : Vect 3 (Vect 3 Int)
      matrix21 = [ [0, 0, 0],
                   [4, 1, 9],
                   [0, 8, 0] ]
      matrix22 : Vect 3 (Vect 3 Int)
      matrix22 = [ [2, 8, 0],
                   [0, 0, 5],
                   [0, 7, 9] ]

vars : Tensor [3, 3, 3, 3] String
vars = toTensor
        [ [ [ ["x_" ++ show i0 ++ "_" ++ show i1 ++ "_" ++ show i2 ++ "_" ++ show i3
             | i3 <- [0, 1, 2]]
             | i2 <- [0, 1, 2]]
             | i1 <- [0, 1, 2]]
             | i0 <- [0, 1, 2]]

cells : Tensor [3, 3, 3, 3] (Expr (NumT IntT)) -> Expr BoolT
cells ts with (toVect ts)
  cells ts | xssss = let xs = concat $ concat $ concat xssss in
                    and $ map (\x => (int 1) <= x && x <= (int 9)) xs

rows : Tensor [3, 3, 3, 3] (Expr (NumT IntT)) -> Expr BoolT
rows ts with (toVect ts)
  rows ts | xssss = let rs = concat $ map zipRows xssss in
                    and $ map distinct rs
  where
    zipRows : Vect 3 (Vect 3 (Vect 3 (Expr (NumT IntT)))) -> Vect 3 (Vect 9 (Expr (NumT IntT)))
    zipRows xsss = zipWith3 (\xs, ys, zs => xs ++ ys ++ zs) (index 0 xsss) (index 1 xsss) (index 2 xsss)

cols : Tensor [3, 3, 3, 3] (Expr (NumT IntT)) -> Expr BoolT
cols ts with (toVect ts)
  cols ts | xssss = let rs = concat $ map zipCols $ map (map transpose) $ transpose xssss in
                        and $ map distinct rs
  where
    zipCols : Vect 3 (Vect 3 (Vect 3 (Expr (NumT IntT)))) -> Vect 3 (Vect 9 (Expr (NumT IntT)))
    zipCols xsss = zipWith3 (\xs, ys, zs => xs ++ ys ++ zs) (index 0 xsss) (index 1 xsss) (index 2 xsss)

square : Tensor [3, 3, 3, 3] (Expr (NumT IntT)) -> Expr BoolT
square ts with (toVect ts)
  square ts | xssss = and $ map (\xss => distinct (concat xss)) $ concat xssss

instanceCheck : Tensor [3, 3, 3, 3] Int -> Tensor [3, 3, 3, 3] (Expr (NumT IntT)) -> Expr BoolT
instanceCheck insts vars with (toVect insts, toVect vars)
  instanceCheck insts vars | (insts', vars') = let insts'' = concat $ concat $ concat insts' in
                                               let vars'' = concat $ concat $ concat vars' in
                                               and $ zipWith (\inst, var => ite ((int inst) == (int 0)) (bool True) ((int inst) == var)) insts'' vars''

sudoku : Smt ()
sudoku = do vars <- declareVars vars (NumT IntT)
            assert $ cells vars
            assert $ rows vars
            assert $ cols vars
            assert $ square vars
            assert $ instanceCheck puzzle vars
            checkSat
            getModel
            end


module BezoutsIdentity

import Data.Vect

{-

NOTES

Though the assumptions seem so obvious you shouldn't have to prove them,
either they're wrong together or Idris is very broken, because we've
proven (6 = 2) by proving (a, b)===(0, 1) satisfies a*4+b*6 = gcd 4 6.
I suspect the error is `subtractionexchangepr` and subtraction of Nats
is broken, but it could also be `gcddef`, which shows up in the
expression for the proof of this fact a few times (and shows up
in the correct computations we've seen as well).

Further, the linear combination can't be right, because the only solutions
have negative coefficients in them.

Oh! No, it's clearly modeqpr that's wrong. It assumes (+k).(-k) = id.
But subtractionexchangepr might still be wrong for the same reason.

===========================================

TODO

Prove bezoutsIdentityNat rigorously and over ZZ. Find the contradiction

	> bezoutsIdentityNat 4 6

is false while

	> bezoutsIdentityNat 4 2

is true.

But we CAN'T just do it over ZZ, because `gcd` is not defined for it (what??).
We need to use Int or Integral or (Integral a, Quasigroup a) => a, but be warned
this algorithm will still fail if the number system has Integral instantiated but
it is not either one of those two or a Euclidean domain.

	Prelude.Nat.toIntNat : Nat -> Int
	Tail recursive cast Nat to Int Note that this can overflow

	Prelude.Nat.toIntegerNat : Nat -> Integer
	Convert a Nat to an Integer

So we want to use Integer instead of Int.

	Prelude.Nat.fromIntegerNat : Integer -> Nat
	Convert an Integer to a Nat, mapping negative numbers to 0

We can use this to build a nice `abs`.

Remove gcddef by proving this trivial lemma

Remove junk from lemma_gcdrecpr by inspecting the proof
See if it can't be done in a more uniform style
 style 1a) more letting things be the Refl ComputableThm
 style 1b) more claims of equalities combined combinatorially
 style 2) more functional, creating intermediate assumptions by applying
 	Clearly gluemap is the wrong kind of function.
 	On the other hand, we described how to express the proof maneuvers as plumbing.
 	Maybe we could extend the plumbing to where we don't need some of the proof hints,
 	say by replacing the value whose equal expression needs to be hinted at being
 	wrapped in a function definition with a relative derivation by some other function
 	that rewrite w/ cong will be happy to recognize, such as so factorizing the thm at claim.

Expressions of the plumbing being performed that are more generally are desired

Perhaps we should call what we're proving now the Euclidean division algorithm,
and call the witness-erased form, corresponding to the existential form of the
conclusion, the true Bezout's theorem.
> :apropos Exists

Refactor into modules based on independence of origins.

===========================================

IMPACT OF LANGUAGE GAPS ON CODE

Here's some semantics errors within rewrite, possibly due to misscoping.
This was found in lemma_gcdrecpr, right where ?subtractionexchange is made.

> rewrite sym ( ( the ( (a : Nat) -> (b : Nat) -> (c : Nat) -> (a-b)+c = a+(c-b) ) ?subtractionexchange ) $ ( a*d ) $ ( (b*(div (c-r) d))*d ) $ ( b*c ) )
	Error: Perhaps a is applied to too many arguments
> rewrite sym ( ( the ( (x : Nat) -> (y : Nat) -> (z : Nat) -> (x-y)+z = x+(z-y) ) ?subtractionexchange ) ( a*d ) ( (b*(div (c-r) d))*d ) ( b*c ) )
	Error: No such variable x

Some things can't be made private even though they shouldn't be used outside this module,
because doing so will change how things in this module that use them typecheck, creating
a bug which allows a using function's type to be checked but appears undeclared when called.
This was found by making gcdwzeroproof private and checking the type of bezoutsIdentityNat 1.

Making gcdwzeroproof private also prevents gcdnormally=?gcdnormallyproof from being able to access
all the variables from the environment that are involved.

It would be nice if we knew how to use a proof of equality of types to refine a goal.
Maybe it would use refine.
We need to prove the type of the goal matches what we have,
not that we have a value of the goal type.

Then we could replace (bezeqty c d nn) with
	let (a,b)=nn in a*c+b*d = gcd c d
or	(\(a,b) => a*c+b*d = gcd c d) nn

-}

gcdwzeroproof : (cc : Nat) -> plus (plus cc 0) 0 = cc
gcdwzeroproof = proof
	intro
	rewrite sym (plusCommutative cc 0)
	rewrite sym (plusCommutative cc 0)
	trivial

gcddef : (a : Nat) -> (b : Nat) -> ( gcd a b = assert_total (gcd b (modNat a b)) )
-- Type mismatch on the equality, even though the things are equal by def.
-- gcddef a b = Refl
gcddef a b = believe_me "by definition"

{-

Proof sketch
In this style, some of the arrows are tautological from prior knowledge
If the use of `r` for `modNat c d` til the conclusion were followed,
the actual proof would be easier to follow and more elegantly written.

lemma_gcdrec : (c : Nat) -> (d : Nat) -> (r : Nat) -> (a : Nat) -> (b : Nat)
	-> (r = modNat c d)
	-> (a*d+b*r = gcd d r)
	-> ( gcd d r = gcd c d ) --by def of gcd
	-> ( a*d + b*r = gcd c d ) -- by subst b-n previous two

	-> ( r+(div (c-r) d)d = c ) -- Solution exists by lifting r over multiples of d to c. Namely, d | c-r.
	-> ( r = c-(div (c-r) d)d ) -- by cong on subtraction
	-> ( (a*d + b*(c-(div (c-r) d)*d)) = gcd c d ) -- by subst b-n prev 3
	-> ( ((a-b*(div (c-r) d))*d + b*c) = gcd c d ) -- by distrib then assoc then distrib

-}

lemma_gcdrec : (c : Nat) -> (d : Nat) -> (a : Nat) -> (b : Nat)
	-> ( gcdformknown : a*d+b*(modNat c d) = gcd d (modNat c d))
	-> ( ((a-b*(div (c-(modNat c d)) d))*d + b*c) = gcd c d )
lemma_gcdrec = ?lemma_gcdrecpr

-- A bunch of this is junk. If we try again, we can cut that out.
lemma_gcdrecpr = proof
  intros
  claim lincombformknown ( a*d+b*(modNat c d) = gcd c d )
  unfocus
  claim modeq ( modNat c d = c-(div (c-(modNat c d)) d)*d )
  unfocus
  claim substform ( ((a-b*(div (c-(modNat c d)) d))*d + b*c) = gcd c d )
  unfocus
  rewrite sym ( multDistributesOverMinusLeft a (b*(div (c-(modNat c d)) d)) d )
  claim subtractionexchange (x : Nat) -> (y : Nat) -> (z : Nat) -> plus (minus x y) z = plus x (minus z y)
  unfocus
  rewrite sym ( subtractionexchange (a*d) ( (b*(div (c-(modNat c d)) d))*d ) ( b*c ) )
  rewrite sym (sym $ multAssociative b (div (c-(modNat c d)) d) d)
  rewrite sym (sym $ multDistributesOverMinusRight b c ((div (c-(modNat c d)) d)*d))
  claim substform' ( (a*d + b*(c-(div (c-(modNat c d)) d)*d)) = gcd c d )
  unfocus
  exact substform'
  rewrite sym (gcddef c d)
  exact gcdformknown
  unfocus
  exact (believe_me "Rm this junk")
  exact ?subtractionexchangepr
  rewrite sym (gcddef c d)
  -- rewrite sym (sym modeq) is no-opping, but should solve the main thm
  --    REDO: Maybe we just need to use compute to normalize the goal terms beforehand?
  -- So, we have to add hints, namely factoring through what we call
  -- reachfortheglue and applying cong and trans.
  -- The type of such a maneuver is roughly {a : A} -> {b : A} -> {c : B} -> (a = b) -> { f : A -> B } -> ( f b = c ) -> ( f a = c )
  -- This gluemap map is junk we recreate later.
  claim gluemap ( gf : plus (mult a d) (mult b (modNat c d)) = gcd d (modNat c d) ) -> ( me : modNat c d = c - div (c - modNat c d) d * d ) -> a * d + b * (c - div (c - modNat c d) d * d) = gcd d (modNat c d)
  intros
  let reachfortheglue = \v => plus (mult a d) (mult b v)
  let rftgv = cong {f=reachfortheglue} me
  let fv = the ( reachfortheglue ( c - div (c - modNat c d) d * d ) = plus (mult a d) (mult b $ c - div (c - modNat c d) d * d) ) Refl
  let t_rftgv_fv = trans rftgv fv
  let t_trftgvfg_gf = trans (sym t_rftgv_fv) gf
  exact t_trftgvfg_gf
  let reachfortheglue = \v => plus (mult a d) (mult b v)
  let rftgv = cong {f=reachfortheglue} modeq
  let fv = the ( reachfortheglue ( c - div (c - modNat c d) d * d ) = plus (mult a d) (mult b $ c - div (c - modNat c d) d * d) ) Refl
  let t_rftgv_fv = trans rftgv fv
  let t_trftgvfg_gf = trans (sym t_rftgv_fv) gcdformknown
  exact t_trftgvfg_gf
  exact (?modeqpr c d)

total
bezeqty : Nat -> Nat -> (Nat,Nat) -> Type
bezeqty c d (a,b) = a*c+b*d = gcd c d

lemma_gcdrecdepparout : (c : Nat) -> (d : Nat) -> (a : Nat) -> (b : Nat)
	-> ( gcdformknown : bezeqty d (modNat c d) (a,b))
	-> ( nn:(Nat,Nat) ** bezeqty c d nn )
lemma_gcdrecdepparout = ?lemma_gcdrecdepparoutpr

lemma_gcdrecdepparoutpr = proof
  intros
  claim imedeq ( b*c + (a-b*(div (c-(modNat c d)) d))*d = gcd c d )
  unfocus
  exact ( (b, (a - b * div (c - modNat c d) d)) ** imedeq )
  -- here we see the sum in the conclusion of lemma_gcdrec
  -- differs in term order from that needed
  rewrite sym (sym $ lemma_gcdrec c d a b gcdformknown)
  compute
  rewrite sym ( plusCommutative (mult b c) (mult (minus a (mult b (div (minus c (modNat c d)) d))) d) )
  exact Refl

bezoutsIdentityNat : (c:Nat) -> (d:Nat)
	-> ( nn : (Nat,Nat) ** bezeqty c d nn )
bezoutsIdentityNat c Z = ((1,0) ** gcdwzero)
	where
		gcdwzero = gcdwzeroproof c
bezoutsIdentityNat c d with (bezoutsIdentityNat d (modNat c d))
	| ((a,b) ** oldpr) = lemma_gcdrecdepparout c d a b oldpr


import IsEven
import Matrix
import VecSort
import Vectors
import WordLength
import WordLength_vec
import XOR


||| This module can be used to run an SF for a long time
||| as quickly as possible to check for memory leaks.
module Test.Leak

import Control.ANSI.CSI
import Control.Monad.Identity
import Control.Monad.Reader
import Control.MonadRec
import Data.Fuel
import Data.Iterable
import Data.MSF
import Data.MSF.Running
import Data.MSF.Switch
import Data.MSF.Trans
import Data.String

%default total

--------------------------------------------------------------------------------
--          Some FRP primitives
--------------------------------------------------------------------------------

DTime : Type
DTime = Double

SF : Type -> Type -> Type
SF = MSF (ReaderT DTime Identity)

Velocity : Type
Velocity = Double

Acceleration : Type
Acceleration = Double

integralFrom : (v0 : Double) -> SF Double Double
integralFrom v0 = fan [id, iPre v0, ask] >>> accumulateWith next 0
  where next : NP I [Double,Double,DTime] -> Double -> Double
        next [new,old,dt] acc = acc + (dt / 2 * (new + old))

acc : Acceleration
acc = -9.81

velocity : (v0 : Velocity) -> (a0 : Acceleration) -> SF Acceleration Velocity
velocity v0 a0 = integralFrom a0 >>^ (+ v0)

position : (p0 : Double) -> (v0 : Velocity) -> SF Velocity Double
position p0 v0 = integralFrom v0 >>^ (+ p0)

--------------------------------------------------------------------------------
--          Bouncing Ball
--------------------------------------------------------------------------------

record Ball where
  constructor MkBall
  pos : Double
  vel : Velocity

dispBall : NP I [Ball,Nat] -> String
dispBall [b,n] =
  let char = if b.vel <= 0 then '<' else '>'
   in    cursorUp1
      ++ eraseLine End
      ++ padLeft 9 ' ' (show n)
      ++ "  "
      ++ replicate (cast b.pos) char

ballFrom : Ball -> SF i Ball
ballFrom (MkBall p0 v0) =
      const acc
  >>> velocity v0 acc
  >>> fan [position p0 v0, id]
  >>^ \[p,v] => MkBall p v

bounce : Ball -> Event (SF i Ball)
bounce (MkBall y vy) =
  if y <= 0 then Ev . ballFrom $ MkBall y (-vy) else NoEv

ballGame : Ball -> SF i Ball
ballGame b0 = feedback NoEv $ rSwitch (ballFrom b0) >>> fan [arr bounce, id]

game : MSF Identity () Ball
game = const 0.0001 >>> fromReader_ (ballGame $ MkBall 80 0)

controller : MSF IO () ()
controller = morph (pure . runIdentity) (fan [game,count]) >>! putStrLn . dispBall

run : Fuel -> IO ()
run f = iterM (\_,sf => snd <$> step sf ()) (const ()) controller f

||| This uses monad morphisms and recursive switches under the hood,
||| which were problematic in earlier implementations. Hence this test
||| that they behave correctly over a prolonged period of time.
partial
main : IO ()
main = run (limit 10000000)


module Main

-- Test wraparound from upper bounds of Bits types
main : IO ()
main = do putStrLn (show $ the Bits16 maxBound)
          putStrLn (show $ the Bits16 maxBound + 1)
          putStrLn (show $ the Bits32 maxBound)
          putStrLn (show $ the Bits32 maxBound + 1)
          putStrLn (show $ the Bits64 maxBound)
          putStrLn (show $ the Bits64 maxBound + 1)


module Crypto.ECDH

import Crypto.Random
import Crypto.Curve.XCurves
import Crypto.Curve
import Data.Vect
import Utils.Misc
import Utils.Bytes

public export
interface ECDHCyclicGroup (0 a : Type) where
  Scalar : Type
  Element : Type
  diffie_hellman : Scalar -> Element -> Maybe (List Bits8)
  generate_key_pair : MonadRandom m => m (Scalar,Element)

  deserialize_pk : List Bits8 -> Maybe Element
  serialize_pk : Element -> List Bits8

public export
deserialize_then_dh : ECDHCyclicGroup dh => Scalar {a=dh} -> List Bits8 -> Maybe (List Bits8)
deserialize_then_dh sk pk = (deserialize_pk {a=dh} pk) >>= (diffie_hellman sk)

public export
data X25519_DH : Type where

public export
ECDHCyclicGroup X25519_DH where
  Scalar = Vect 32 Bits8
  Element = Vect 32 Bits8
  diffie_hellman sk pk = map toList (XCurves.mul x25519 sk pk)
  generate_key_pair = do
    sk <- random_bytes 32
    let Just pk = derive_public_key x25519 sk
    | Nothing => generate_key_pair {a=X25519_DH}
    pure (sk,pk)
  deserialize_pk content = exactLength 32 $ fromList content
  serialize_pk = toList

public export
data X448_DH : Type where

public export
ECDHCyclicGroup X448_DH where
  Scalar = Vect 56 Bits8
  Element = Vect 56 Bits8
  diffie_hellman sk pk = map toList (XCurves.mul x448 sk pk)
  generate_key_pair = do
    sk <- random_bytes 56
    let Just pk = derive_public_key x448 sk
    | Nothing => generate_key_pair {a=X448_DH}
    pure (sk,pk)
  deserialize_pk content = exactLength 56 $ fromList content
  serialize_pk = toList

public export
{p : _} -> Point p => ECDHCyclicGroup p where
  Scalar = Integer
  Element = p
  diffie_hellman sk pk =
    let (x, _) = to_affine $ mul sk pk
        bytes = divCeilNZ (bits {p=p}) 8 SIsNonZero
    in Just $ toList $ integer_to_be bytes x
  generate_key_pair = do
    sk <- uniform_random' 2 (order {p=p} - 1)
    let pk = mul sk $ generator {p=p}
    pure (sk,pk)
  deserialize_pk = decode {p=p}
  serialize_pk = encode {p=p}


data Foo : Nat -> Type where

0 G : (0 yv : Nat) -> Type
G yv = Foo yv -> Bool

partial
f : (0 x : Nat) -> Nat
f x = case G x of
           (Foo x' -> _) => x'


module Main

next : Nat -> Stream Nat
next n = (n :: Delay (next (S n)))

data InfIO : Type where
  Do : IO a -> (a -> Inf InfIO) -> InfIO

-- sugar me with do-notation
(>>=) : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) = Do

-- First try, infinite IO with partial run

loopPrint : Nat -> InfIO
loopPrint x = do putStrLn (show x)
                 loopPrint (S x)

run : InfIO -> IO ()
run (Do x f) = do res <- x
                  run (f res)

-- Second try, finine infinite IO with total run

data Fuel : Type where
  Dry : Fuel
  More : Fuel -> Fuel

tank : Nat -> Fuel
tank Z = Dry
tank (S k) = More (tank k)

total runTank : Fuel -> InfIO -> IO ()
runTank Dry _ = putStrLn "Out of Fuel"
runTank (More fuel) (Do c f) = do res <- c
                                  runTank fuel (f res)

-- Third try, Lazy Fuel for infinite infinite IO with a total run

data Gas : Type where
  Empty : Gas
  Some : Lazy Gas -> Gas

data Run : Type where
  Stop : Run
  Step : Lazy Run -> Run

total runEngine : Gas -> InfIO -> IO ()
runEngine Empty y = putStrLn "Out of fuel"
runEngine (Some x) (Do y f) = y >>= \res => runEngine x (f res)

freeGas : Gas
freeGas = Some freeGas

main : IO ()
main = runEngine freeGas (loopPrint 0)

h : Nat -> () -> Nat
h x = \_ => (+) x 1

h' : Nat -> Lazy Nat
h' x = (+) x 1


module Patricia.IntSet

import Patricia.IntMap

%default total
%access export

public export
data IntBitSet : (bits : Nat) -> Type where
  MkIntSet : IntBitMap bits Unit -> IntBitSet bits

||| Integer set with 32 bits integers as an element.
public export
Int32Set : Type
Int32Set = IntBitSet 32

||| `O(n)`. Number of elements in `IntBitSet`.
public export
size : IntBitSet (S n) -> Nat
size (MkIntSet t) = size t

||| `O(min(n, W))`. Check if the value is in the `IntBitSet`.
public export
member : Integer -> IntBitSet (S n) -> Bool
member x (MkIntSet t) = isJust (lookup x t)

||| `O(min(n,W))`. Insert a new `value` in the `IntBitSet`.
||| If the value is already present in the set, the tree isn't changed.
public export
insert : Integer -> IntBitSet (S n) -> IntBitSet (S n)
insert x (MkIntSet t) = MkIntSet (insert x () t)

||| `O(min(n,W))`. Delete the `value` from `IntBitSet`.
||| If the value is not present in the set, the tree isn't changed.
public export
delete : Integer -> IntBitSet (S n) -> IntBitSet (S n)
delete x (MkIntSet t) = MkIntSet (delete x t)

||| Create `IntBitSet` from list of `value`.
public export
fromList : List Integer -> IntBitSet (S n)
fromList = MkIntSet . fromList . map (\x => (x, ()))


%default total

--------------------------------------------------------
-- Shrunk

data D : List (List a) -> Type where
  C1 : D [ts]
  C2 : D [ts]

f : D [[Maybe a]] -> Nat
f C1 = 0
f C2 = 0

--------------------------------------------------------
-- Original bug report

data NP : (ts : List Type) -> Type where
  Nil  : NP []
  (::) : (v : t) -> (vs : NP ts) -> NP (t :: ts)

data NS : (kss : List $ List Type) -> Type where
  Z : (vs : NP ts) -> NS (ts :: tss)
  S : NS tss -> NS (ts :: tss)

Uninhabited (NS []) where
  uninhabited (Z _) impossible
  uninhabited (S _) impossible

data Funny : (a : Type) -> (f : Type -> Type) -> Type where
  A : List a -> f a -> Funny a f
  B : Funny a f

decode : NS [[List a, f a], []] -> Funny a f
decode (Z [a,b])  = A a b
decode (S (Z [])) = B


-- --------------------------------------------------------------- [ Day08.idr ]
-- Module      : Data.Advent.Day08
-- Description : My solution to the Day 8 puzzle of the 2016 Advent of Code.
-- Copyright   : Copyright (c) 2016, Eric Bailey
-- License     : MIT
-- Link        : http://adventofcode.com/2016/day/7
-- --------------------------------------------------------------------- [ EOH ]
||| Day 8: Two-Factor Authentication
module Data.Advent.Day08

import Data.Vect

import public Lightyear
import public Lightyear.Char
import public Lightyear.Strings
import public Lightyear.StringFile

%default total

-- -------------------------------------------------------------- [ Data Types ]

%access public export

data Pixel = Off | On

implementation Eq Pixel where
    On  == On  = True
    Off == Off = True
    px1 == px2 = False

implementation Show Pixel where
    show Off = "."
    show On  = "#"

Screen : Nat -> Nat -> Type
Screen w h = Vect h (Vect w Pixel)

implementation [showScreen] Show (Screen w h) where
    show = unlines . toList . map (concatMap show)

data Rect : Nat -> Nat -> Type where
     MkRect : Fin w -> Fin h -> Rect w h

implementation Show (Fin n) where
    show = show . finToNat

-- showFin : Fin n -> String
-- showFin = show . finToNat

implementation Show (Rect w h) where
    show (MkRect w h) = "rect " ++ show w ++ "x" ++ show h

data Rotate : Nat -> Nat -> Type where
     Row : Fin w -> Fin h -> Rotate h w
     Col : Fin w -> Fin h -> Rotate w h

implementation Show (Rotate xy by) where
    show (Row y by) = "rotate row y=" ++ show y ++ " by " ++ show by
    show (Col x by) = "rotate column x=" ++ show x ++ " by " ++ show by

-- ----------------------------------------------------------------- [ Parsers ]

%access export

partial
side : (n : Nat) -> Parser (Fin n)
side n = do Just len <- (\m => integerToFin m n) <$> integer
              | Nothing => fail "out of bounds"
            pure len

partial
rect : Parser (Rect w h)
rect = liftA2 MkRect (token "rect" *> side w)
                     (token "x"    *> side h)  <?> "rect AxB"

partial
maybeFin : (n : Nat) -> Parser (Maybe (Fin n))
maybeFin n = marshal <$> integer <* spaces <?>
             "a number strictly less than " ++ show n
  where
    marshal : Integer -> Maybe (Fin n)
    marshal m = integerToFin m n

partial
row : Parser (Rotate w h)
row {w} {h} = do Just y  <- token "rotate row y=" *> maybeFin h
                 Just by <- token "by" *> maybeFin w
                 pure $ Row y by

partial
column : Parser (Rotate w h)
column {w} {h} = do Just x  <- token "rotate column x=" *> maybeFin w
                    Just by <- token "by" *> maybeFin h
                    pure $ Col x by

partial
rotation : Parser (Rotate w h)
rotation = row <|> column <?> "a rotation"

partial
rectOrRotation : Parser (Either (Rect w h) (Rotate w h))
rectOrRotation {w} {h} = case !(opt (rect {w} {h})) of
                              Just rec => pure $ Left rec
                              Nothing  => Right <$> rotation {w} {h}

-- ----------------------------------------------------------------- [ Helpers ]

%access private

mapIndexed : (f : (a, Nat) -> a) -> Vect n a -> Vect n a
mapIndexed f xs {n} = map f (zip xs (go n Z))
  where
    go : (m : Nat) -> Nat -> Vect m Nat
    go Z _     = []
    go (S k) x = x :: go k (S x)

-- ------------------------------------------------------------------ [ Proofs ]

%access private

finToLTE : (f : Fin n) -> LTE (finToNat f) n
finToLTE FZ               = LTEZero
finToLTE (FS _) {n = S _} = LTESucc (finToLTE _)

total compositeLemma : (left, right : Nat) -> {auto smaller : LTE left right} ->
  (k : Nat ** right = left + k)
compositeLemma left right = (right - left ** go left right)
  where
    go : (left, right : Nat) -> {auto smaller : LTE left right} ->
      right = left + (right - left)
    go Z right        = rewrite minusZeroRight right in Refl
    go (S k) (S j) {smaller} =
        let inductiveHypothesis = go k j {smaller = fromLteSucc smaller} in
            eqSucc j (k + (minus j k)) inductiveHypothesis

total updateLemma : (prf : n = finToNat by + m) -> n = m + finToNat by
updateLemma {by} {m} prf = rewrite plusCommutative m (finToNat by) in prf

-- -- ---------------------------------------------------------------- [ Logic ]

turnOn : Rect sw sh -> Screen sw sh -> Screen sw sh
turnOn (MkRect w h) = mapIndexed f
  where
    g : (Pixel, Nat) -> Pixel
    g (col, x) = if x < (finToNat w) then On else col
    f : (Vect m Pixel, Nat) -> Vect m Pixel
    f (row, y) = if y < (finToNat h) then mapIndexed g row else row

namespace Vect

  rotate : (by : Fin n) -> Vect (finToNat by + m) a ->
           (m ** Vect (m + finToNat by) a)
  rotate by xs {m} = let (ys,zs) = splitAt (finToNat by) xs in
                         (m ** zs ++ ys)

updateRow : (by : Fin n) -> (row : Vect n Pixel) -> Vect n Pixel
updateRow {n} by row =
    let (m ** prf)    = compositeLemma (finToNat by) n {smaller = finToLTE by}
        (_ ** newRow) = rotate by $ the (Vect (finToNat by + m) _) $
                        rewrite sym prf in row in
                        rewrite updateLemma prf in
                                newRow

namespace Fin

    rotate : Fin n -> Fin n
    rotate f {n} = let x = (-) n (finToNat f) {smaller = finToLTE f} in
                       fromMaybe f (natToFin x n) -- HACK

namespace Screen

  empty : {w, h : Nat} -> Screen w h
  empty {w} {h} = replicate h (replicate w Off)

  rotate : (Rotate w h) -> Screen w h -> Screen w h
  rotate (Row y by) screen     = updateAt y (updateRow (rotate by)) screen
  rotate (Col x by) screen {h} = transpose $
                                 updateAt x (updateRow (rotate by)) $
                                 transpose screen

howManyLit : Screen w h -> Nat
howManyLit = foldr ((+) . foldr go Z) Z
  where
    go : Pixel -> Nat -> Nat
    go On  = S
    go Off = id

justDoIt : List (Either (Rect w h) (Rotate w h)) -> Screen w h
justDoIt = foldl (\s => either (flip turnOn s) (flip rotate s)) empty

-- ---------------------------------------------------------------- [ Examples ]

ex1 : Screen 7 3
ex1 = turnOn (MkRect 3 2) empty

ex2 : Screen 7 3
ex2 = rotate (Col 1 1) ex1

ex3 : Screen 7 3
ex3 = rotate (Row 0 4) ex2

ex4 : Screen 7 3
ex4 = rotate (Col 1 1) ex3

partial
examples : Either String (List (Either (Rect 7 3) (Rotate 7 3)))
examples = parse (some (rectOrRotation <* spaces)) $ unlines [
             "rect 3x2",
             "rotate column x=1 by 1",
             "rotate row y=0 by 4",
             "rotate column x=1 by 1"
           ]

||| Convenient representation of Part One examples for the REPL.
partial
prettyExamples : Either String (List (List String))
prettyExamples = transpose .
                 map (lines . show @{showScreen}) .
                 scanl (\s => either (flip turnOn s) (flip rotate s)) empty <$>
                 examples

-- -------------------------------------------------------------- [ Main Logic ]

%access export

main' : Parser a -> (a -> String) -> IO ()
main' p f =
    either putStrLn (putStrLn . f)
           !(run $ parseFile (const show) (const id) p "input/day08.txt")

-- ---------------------------------------------------------------- [ Part One ]

namespace PartOne

    partial main : IO ()
    main = main' (some (rectOrRotation {w=50} {h=6} <* spaces))
                 (show . howManyLit . justDoIt)

-- ---------------------------------------------------------------- [ Part Two ]

namespace PartTwo

    partial main : IO ()
    main = main' (some (rectOrRotation {w=50} {h=6} <* spaces))
                 (show @{showScreen} . justDoIt)

-- -------------------------------------------------------------------- [ Main ]

namespace Main

    partial main : IO ()
    main = putStr   "Part One: " *> PartOne.main *>
           putStrLn "Part Two:"  *> PartTwo.main

-- --------------------------------------------------------------------- [ EOF ]