module Depling

import Data.Vect
import Debug.Trace
import Utils

infixl 10 =!=
mutual
	public export
	data DAST : Nat -> Type where
		ʌ : Fin n -> DAST n
		λ : DAST n -> DAST (S n) -> DAST n
		λT : DAST n -> DAST (S n) -> DAST n
		(=!=) : DAST n -> DAST n -> DAST n
		𝕋 : DAST n
		𝔽 : DAST n -> DAST (S n) -> DAST (S$ S$ n) -> DAST n
		𝕌 : String -> DAST n -> DAST n
		ℂ : DCon a -> Vect a (DAST n) -> DAST n
		ℙ : DAST n -> DCon a -> DAST (a + n) -> DAST n -> DAST n
		𝔹 : DAST n -> DAST n

	public export
	data DCon : Nat -> Type where
		DConV : String -> DRCtx a 0 -> DAST a -> DCon a

	public export
	data DRCtx : Nat -> Nat -> Type where
		Nil : DRCtx Z n
		(::) : DAST n -> DRCtx l (S n) -> DRCtx (S l) n

Show (Fin n) where
	show = show . finToNat

Show (DAST n) where
	showPrec d (ʌ v) = show v
	showPrec d (λ at b) = showParens (d > Open) $ "λ" ++ showPrec Eq at ++ "=" ++ showPrec Open b
	showPrec d (λT at rt) = showParens (d > Open) $ "λ" ++ showPrec Eq at ++ ":" ++ showPrec Open rt
	showPrec d (f =!= a) = showParens (d >= App) $ showPrec Eq f ++ "!" ++ showPrec App a
	showPrec d 𝕋 = "Type"
	showPrec d (𝔽 at rt b) = showParens (d > Open) $ "𝔽" ++ showPrec Eq at ++ "=" ++ showPrec Open b
	showPrec d (𝕌 n t) = showParens (d > Open) $ "𝕌" ++ n ++ ":" ++ showPrec Open t
	showPrec d (ℂ (DConV n ats rt) as) = "ℂ" ++ n ++ "(" ++ (pack $ intercalate [',', ' '] $ toList $ map (unpack . showPrec Open) as) ++ ")"
	showPrec d (ℙ v (DConV n ats rt) t f) = "ℙ(" ++ showPrec Eq v ++ " of " ++ n ++ " then " ++ showPrec Eq t ++ " else " ++ showPrec Eq f ++ ")"
	showPrec d (𝔹 t) = "𝔹(" ++ showPrec Open t ++ ")"

mutual
	export Eq (DAST n) where
		(ʌ a) == (ʌ b) = a == b
		(λ aa ba) == (λ ab bb) = aa == ab && ba == bb
		(λT aa ra) == (λT ab rb) = aa == ab && ra == rb
		(fa =!= aa) == (fb =!= ab) = fa == fb && aa == ab
		𝕋 == 𝕋 = True
		(𝔽 aa ra fa) == (𝔽 ab rb fb) = aa == ab && ra == rb && fa == fb
		(𝕌 na ta) == (𝕌 nb tb) = na == nb && ta == tb
		(ℂ {a=aa} cna asa) == (ℂ {a=ab} cnb asb) = assert_total $ aa == ab && cna == believe_me cnb && asa == believe_me asb
		(ℙ {a=aa} va cna ta fa) == (ℙ {a=ab} vb cnb tb fb) = assert_total $ aa == ab && va == vb && cna == believe_me cnb && ta == believe_me tb && fa == fb
		(𝔹 ta) == (𝔹 tb) = ta == tb
		_ == _ = False

	export Eq (DCon a) where
		(DConV na atsa rta) == (DConV nb atsb rtb) = na == nb && atsa == atsb && rta == rtb

	export Eq (DRCtx l n) where
		Nil == Nil = True
		(ha :: ta) == (hb :: tb) = assert_total $ ha == hb && ta == tb
		_ == _ = False

total
export
dAppN : DAST n -> List (DAST n) -> DAST n
dAppN f [] = f
dAppN f (h :: t) = dAppN (f =!= h) t

total
export
dLamN : {a : Nat} -> {n : Nat} -> DRCtx a n -> DAST (a + n) -> DAST n
dLamN {a=Z} [] rt = rt
dLamN {a=S a} {n} (h :: t) rt = λ h $ dLamN t $ replace (plusSuccRightSucc a n) $ rt


module LongestNonRepeatingSubstring

Set : Type -> Type
Set = List

contains : Eq a => a -> Set a -> Bool
contains x [] = False
contains x (y :: ys) = (x == y) || contains x ys

add : a -> Set a -> Set a
add x xs = x :: xs

emptySet : {0 a : Type} -> Set a
emptySet = []

longestHelp : {0 a : Type} -> Eq a => Set a -> Int -> Int -> List a -> Int
longestHelp seen count soFar [] = max soFar count
longestHelp seen count soFar (x :: xs) =
  if contains x seen then longestHelp (emptySet {a}) 0 (max soFar count) (x :: xs) else
  longestHelp (add x seen) (count + 1) soFar xs

longest : Eq a => List a -> Int
longest = longestHelp (emptySet {a}) 0 0

test1 : longest (unpack "abcabcbb") = 3
test1 = Refl
test2 : longest (unpack "bbbbb") = 1
test2 = Refl
test3 : longest (unpack "pwwkew") = 3
test3 = Refl
test4 : longest (unpack "") = 0
test4 = Refl


-- by Tojans

-- to run this:
-- idris 99bottles.idr
-- > beerSong 1
-- > beerSong 99
-- > beerSong 100 -- throws

beerSong : Fin 100 -> String
beerSong x = verses x where

    -- invoke this in the CLI using `bottlesOfBeer (the (Fin 10) 4)`
    bottlesOfBeer : Fin n -> String
    bottlesOfBeer fZ      = "No more bottles of beer"
    bottlesOfBeer (fS fZ) = "1 bottle of beer"
    bottlesOfBeer k       = (show (finToInteger k)) ++ " bottles of beer"

    verse : Fin n -> String
    verse fZ     = ""
    verse (fS n) =
        (bottlesOfBeer (fS n)) ++ " on the wall,\n" ++
        (bottlesOfBeer (fS n)) ++ "\n" ++
        "Take one down, pass it around\n" ++
        (bottlesOfBeer n) ++ " on the wall\n"

    verses : Fin n -> String
    verses fZ     = ""
    verses (fS n) = (verse (fS n)) ++ (verses n)


import Data.Vect

takeFromStream : List (n ** Vect n Int)
takeFromStream = [(n ** take n [3..]) | n <- [0, 1, 5]]

main : IO ()
main = do printLn takeFromStream


module Subtyping

import Expr
import Maps

%access public export

%default total

data Ty : Type where
  TyTop : Ty
  TyBool : Ty
  TyBase : Id -> Ty
  TyArrow : Ty -> Ty -> Ty
  TyUnit : Ty

namespace Types
  A : Ty
  A = TyBase A

  B : Ty
  B = TyBase B

  C : Ty
  C = TyBase C

  D : Ty
  D = TyBase D

  E : Ty
  E = TyBase E

  F : Ty
  F = TyBase F

data Tm : Type where
  Var : Id -> Tm
  App : Tm -> Tm -> Tm
  Abs : Id -> Ty -> Tm -> Tm
  Tru : Tm
  Fls : Tm
  Test : Tm -> Tm -> Tm -> Tm
  Unit : Tm

subst : (x : Id) -> (s, t : Tm) -> Tm
subst x s (Var y) with (decEq x y)
  subst x s (Var y) | Yes _ = s
  subst x s (Var y) | No _ = Var y
subst x s (App t1 t2) = App (subst x s t1) (subst x s t2)
subst x s (Abs y ty t) with (decEq x y)
  subst x s (Abs y ty t) | Yes _ = Abs y ty t
  subst x s (Abs y ty t) | No _ = Abs y ty (subst x s t)
subst x s Tru = Tru
subst x s Fls = Fls
subst x s (Test t1 t2 t3) = Test (subst x s t1) (subst x s t2) (subst x s t3)
subst x s Unit = Unit

data Value : Tm -> Type where
  V_Abs : Value (Abs x ty t)
  V_Tru : Value Tru
  V_Fls : Value Fls
  V_Unit : Value Unit

data Step : Tm -> Tm -> Type where
  ST_AppAbs : Value t2 -> Step (App (Abs x ty t1) t2) (subst x t2 t1)
  ST_App1 : Step t1 t1' -> Step (App t1 t2) (App t1' t2)
  ST_App2 : Value t1 -> Step t2 t2' -> Step (App t1 t2) (App t1 t2')
  ST_Test : Step t1 t1' -> Step (Test t1 t2 t3) (Test t1' t2 t3)
  ST_TestTru : Step (Test Tru t2 t3) t2
  ST_TestFls : Step (Test Fls t2 t3) t3

infix 4 -+>

(-+>) : Tm -> Tm -> Type
(-+>) = Step

data Subtype : Ty -> Ty -> Type where
  S_Refl : Subtype ty ty
  S_Trans : Subtype ty1 ty2 -> Subtype ty2 ty3 -> Subtype ty1 ty3
  S_Top : Subtype ty TyTop
  S_Arrow : Subtype ty3 ty1 -> Subtype ty2 ty4 ->
            Subtype (TyArrow ty1 ty2) (TyArrow ty3 ty4)

infix 4 <:

(<:) : Ty -> Ty -> Type
(<:) = Subtype

subtyping_example_0 : TyArrow C TyBool <: TyArrow C TyTop
subtyping_example_0 = S_Arrow S_Refl S_Top


over_length : (len : Nat) -> (strs : List String) -> Nat
over_length len strs = length (filter (\str => (length str) > len) strs)


module Main

import Data.List

large : (a: Type) -> a
-- integer larger than 64 bits
large Integer = 3518437212345678901234567890123
-- int close to 2ˆ63
-- we expect some operations will overflow
large Int = 3518437212345678901234567890

small : (a: Type) -> a
small Integer = 437
small Int = 377

numOps : (Num a) => List ( a -> a -> a )
numOps = [ (+), (*) ]

negOps : (Neg a) => List (a -> a -> a)
negOps = [ (-) ]

integralOps : (Integral a) => List (a -> a -> a)
integralOps = [ div, mod ]

binOps : (Num a, Neg a, Integral a) => List (a -> a -> a)
binOps = numOps ++ negOps ++ integralOps

main : IO ()
main = do
  putStrLn $ show (results Integer)
  putStrLn $ show (results Int)
  where
  results : (a:Type) -> (Num a, Neg a, Integral a) => List a
  results a = map (\ op => large a  `op` small a) binOps


module IR.Layout

import IR
import IR.StackSet

%default total

column : Rectangle -> (n : Nat) -> Vect n Rectangle
column r n = column' n r n
  where column' _ _ Z = []
        column' n (MkRectangle x y w h) (S m) =
          let w' = w / fromInteger (toIntegerNat n)
          in MkRectangle (x + w' * fromInteger (toIntegerNat m)) y w' h :: column' n r m

fullLayout : LayoutF wid
fullLayout rect s = zip (integrate s) (replicate (stackLength s) rect)

columnLayout : LayoutF wid
columnLayout rect s = zip (integrate s) (column rect (stackLength s))

mirrorLayout : LayoutF wid -> LayoutF wid
mirrorLayout l (MkRectangle x' y' w' h') s = map (\(wid, MkRectangle x y w h) => (wid, MkRectangle ((y - y') / h' * w' + x') ((x - x') / w' * h' + y') (h / h' * w') (w / w' * h'))) (l (MkRectangle x' y' w' h') s)

single : LayoutF wid -> Layout wid
single l = x
  where x = MkLayout l x

choose : Vect (S n) (LayoutF wid) -> Layout wid
choose {n} {wid} (x::xs) =
  let xs' : Vect (S n) (LayoutF wid) = rewrite plusCommutative 1 n in xs ++ [x]
  in MkLayout x (choose xs')


module Numeric.Floating

public export
interface Fractional ty => Floating ty where
  constructor MkFloating
  pi : ty
  euler : ty
  exp : ty -> ty
  log : ty -> ty
  pow : ty -> ty -> ty -- (**)
  sin : ty -> ty
  cos : ty -> ty
  tan : ty -> ty
  asin : ty -> ty
  acos : ty -> ty
  atan : ty -> ty
  sinh : ty -> ty
  cosh : ty -> ty
  tanh : ty -> ty
  sqrt : ty -> ty

export
Floating Double where
  pi = Prelude.Types.pi
  euler = Prelude.Types.euler
  exp = Prelude.Types.exp
  log = Prelude.Types.log
  pow = Prelude.Types.pow
  sin = Prelude.Types.sin
  cos = Prelude.Types.cos
  tan = Prelude.Types.tan
  asin = Prelude.Types.asin
  acos = Prelude.Types.acos
  atan = Prelude.Types.atan
  sinh = Prelude.Types.sinh
  cosh = Prelude.Types.cosh
  tanh = Prelude.Types.tanh
  sqrt = Prelude.Types.sqrt

-- export
-- Floating Double where
--   pi = 3.14159265358979323846
--   euler = 2.7182818284590452354
--   exp x = prim__doubleExp x
--   log x = prim__doubleLog x
--   pow x y = exp (y * log x) -- prim__doublePow x y
--   sin x = prim__doubleSin x
--   cos x = prim__doubleCos x
--   tan x = prim__doubleTan x
--   asin x = prim__doubleASin x
--   acos x = prim__doubleACos x
--   atan x = prim__doubleATan x
--   sinh x = (exp x - exp (-x)) / 2
--   cosh x = (exp x + exp (-x)) / 2
--   tanh x = sinh x / cosh x -- can this NaN via cosh = 0? can cosh even be 0?
--   sqrt x = prim__doubleSqrt x
--   floor x = prim__doubleFloor x
--   ceiling x = prim__doubleCeiling x


module InterfaceWith0s

interface Lala (a : Type) where
  f : a -> a
  z : a -> a -> Bool
  0 prop : (x : a) -> z (f x) x = True


top_ten : Ord a => List a -> List a
top_ten [] = []
top_ten xs =
  let sortedList = reverse (sort xs) in
  take 10 sortedList


module Data.Profunctor

import Data.Morphisms

public export
interface Profunctor (0 f : Type -> Type -> Type) where
  dimap : (a -> a') -> (b -> b') -> f a' b -> f a b'
  lmap : (a -> a') -> f a' b -> f a b
  rmap : (b -> b') -> f a b -> f a b'

  dimap pre post = rmap post . lmap pre
  lmap pre = dimap pre id
  rmap post = dimap id post


module Main

import IdrisJvm.IO
import Java.Lang
import Java.Util
import Data.Vect

numTest : (Num a, Show a) => a -> a -> JVM_IO ()
numTest a b = do
  putStrLn $ show a ++ " + " ++ show b ++ " = " ++ show (a + b)
  putStrLn $ show a ++ " * " ++ show b ++ " = " ++ show (a * b)

integralTest : (Integral a, Show a) => a -> a -> JVM_IO ()
integralTest a b = do
  putStrLn $ show a ++ " div " ++ show b ++ " = " ++ show (a `div` b)
  -- putStrLn $ show a ++ " mod " ++ show b ++ " = " ++ show (a `mod` b) -- not working due to a defect in Idris portable codegen

fractionalTest : (Fractional a, Show a) => a -> a -> JVM_IO ()
fractionalTest a b = do
  putStrLn $ show a ++ " / " ++ show b ++ " = " ++ show (a / b)
  putStrLn $ "recip " ++ show a ++ " = " ++ show (recip a)
  putStrLn $ "recip " ++ show b ++ " = " ++ show (recip b)

showOrdering : Ordering -> String
showOrdering EQ = "EQ"
showOrdering LT = "LT"
showOrdering GT = "GT"

ordTest : (Ord a, Show a) => a -> a -> JVM_IO ()
ordTest a b = putStrLn $ "compare " ++ show a ++ " " ++ show b ++ " = " ++ showOrdering (compare a b)

int1 : Int
int1 = 2147483647

int2 : Int
int2 = -2147483648

int3 : Int
int3 = 4

integer1 : Integer
integer1 = 100000000000000009

integer2 : Integer
integer2 = 200000000000000008

bits8_1: Bits8
bits8_1 = 255

bits8_2: Bits8
bits8_2 = 255

bits16_1: Bits16
bits16_1 = 4097

bits16_2: Bits16
bits16_2 = 512

bits32_1: Bits32
bits32_1 = 8388608

bits32_2: Bits32
bits32_2 = 524288

bits64_1: Bits64
bits64_1 = 9223372036854775807

bits64_2: Bits64
bits64_2 = 281474976710656

double1 : Double
double1 = 24.234234

double2 : Double
double2 = 75676.23232

printHeader : String -> JVM_IO ()
printHeader header = do
  putStrLn ""
  putStrLn header
  putStrLn $ concat $ List.replicate (length header) "="

pythag : Int -> List (Int, Int, Int)
pythag max = [(x, y, z) | z <- [1..max], y <- [1..z], x <- [1..y],
                          x * x + y * y == z * z]

compareMaybe : (a, Maybe Int, b) -> (a, Maybe Int, b) -> Ordering
compareMaybe (_, Just c1, _) (_, Just c2, _) = compare c1 c2
compareMaybe (_, Just _, _) (_, Nothing, _)  = LT
compareMaybe (_, Nothing, _) (_, Just _, _)  = GT
compareMaybe _ _                             = EQ

maybeTest1 : Maybe String -> JVM_IO ()
maybeTest1 s = putStrLn (maybe "nothing" id s)

maybeTest2 : Maybe String -> JVM_IO ()
maybeTest2 Nothing = putStrLn "nothing"
maybeTest2 _       = putStrLn "just"

maybeTest3 : Maybe String -> JVM_IO ()
maybeTest3 (Just _) = putStrLn "just"
maybeTest3 _        = putStrLn "nothing"

main : JVM_IO ()
main = do
  print "Hello "
  putStrLn "world!"
  printHeader "numTest on Int"
  numTest int1 int2

  printHeader "numTest on Integer"
  numTest integer1 integer2

  printHeader "numTest on Bits8"
  numTest bits8_1 bits8_2

  printHeader "numTest on Bits16"
  numTest bits16_1 bits16_2

  printHeader "numTest on Bits32"
  numTest bits32_1 bits32_2

  printHeader "numTest on Bits64"
  numTest bits64_1 bits64_2

  printHeader "numTest on Double"
  numTest double1 double2

  printHeader "integralTest on Int"
  integralTest int1 int2

  printHeader "integralTest on Integer"
  integralTest integer1 integer2

  printHeader "integralTest on Bits8"
  integralTest bits8_1 bits8_2

  printHeader "integralTest on Bits16"
  integralTest bits16_1 bits16_2

  printHeader "integralTest on Bits32"
  integralTest bits32_1 bits32_2

  printHeader "integralTest on Bits64"
  integralTest bits64_1 bits64_2

  printHeader "fractionalTest on Double"
  fractionalTest double1 double2

  printHeader "ordTest on Int"
  ordTest int1 int2

  printHeader "ordTest on Integer"
  ordTest integer1 integer2

  printHeader "ordTest on Bits8"
  ordTest bits8_1 bits8_2

  printHeader "ordTest on Bits16"
  ordTest bits16_1 bits16_2

  printHeader "ordTest on Bits32"
  ordTest bits32_1 bits32_2

  printHeader "ordTest on Bits64"
  ordTest bits64_1 bits64_2

  printHeader "ordTest on Double"
  ordTest double1 double2

  putStrLn ""
  printLn $ pythag 50

  -- Array tests start
  printLn !(arrayToVect !(vectToArray ['d', 'c', 'a']))
  printLn !(arrayToVect !(vectToArray $ the (Vect _ Int) $ [3, 4, 5]))
  printLn !(arrayToVect !(vectToArray (the (Vect _ Bits8) [2, 4, 6, 5, 3])))
  printLn !(arrayToVect !(vectToArray (the (Vect _ Bits16) [5, 3])))
  printLn !(arrayToVect !(vectToArray (the (Vect _ Bits32) [2, 5, 3])))
  printLn !(arrayToVect !(vectToArray (the (Vect _ Bits64) [2, 4, 6, 5])))
  printLn !(arrayToVect !(vectToArray [Float 0.5, Float 2.0, Float 4.5]))
  printLn !(arrayToVect !(vectToArray [1.3, 1.5, 1.9, 2.5]))
  printLn !(arrayToVect !(vectToArray ["hello", "world", "!"]))

  marr <- newMultiArray (Int -> Int -> Int -> Int -> JVM_IO (JVM_Array (JVM_Array (JVM_Array (JVM_Array String))))) 3 2 2 4
  setArray (JVM_Array (JVM_Array (JVM_Array (JVM_Array String))) -> Int -> Int -> Int -> Int -> String -> JVM_IO ()) marr 0 0 0 3 "foo"
  printLn !(Arrays.deepToString marr)
  printLn !(getArray (JVM_Array (JVM_Array (JVM_Array (JVM_Array String))) -> Int -> Int -> Int -> Int -> JVM_IO String) marr 0 0 0 3)
  printLn !(arrayLength !(getArray (JVM_Array (JVM_Array (JVM_Array (JVM_Array String))) -> Int -> Int -> JVM_IO (JVM_Array (JVM_Array String))) marr 0 0))
  printLn !(arrayLength marr)

  vectArr2d <- vectToArray2d (the (Vect _ (Vect _ Int)) [[3, 33], [4, 44], [5, 55]])
  printLn !(Arrays.deepToString vectArr2d)
  -- Array tests end

  -- Maybe tests
  maybeTest1 (if Strings.length "foo" == 0 then Nothing else Just "foo")
  maybeTest2 (if Strings.length "" == 0 then Nothing else Just "foobar")
  maybeTest3 (if Strings.length "bar" == 0 then Nothing else Just "bar")
  printLn $ sortBy compareMaybe $ [("", Just 10, ""), ("", Just 23, ""), ("", Nothing, ""), ("", Just 15, "")]


public export
interface Do (m : Type) where
  Next : m -> Type
  bind : (x : m) -> Next x

public export
Monad m => Do (m a) where
  Next x = {b : Type} -> (a -> m b) -> m b
  bind x k = x >>= k

foo : Maybe Int -> Maybe Int -> Maybe Int
foo x y
   = bind x (\x' =>
     bind y (\y' => Just (x' + y')))


{-
205
[]
True
True
36
[(1, 5), (1, 6), (2, 5), (2, 6), (11, 5), (11, 6), (11, 7), (12, 4), (12, 8), (13, 3), (13, 9), (14, 3), (14, 9), (15, 6), (16, 4), (16, 8), (17, 5), (17, 6), (17, 7), (18, 6), (21, 3), (21, 4), (21, 5), (22, 3), (22, 4), (22, 5), (23, 2), (23, 6), (25, 1), (25, 2), (25, 6), (25, 7), (35, 3), (35, 4), (36, 3), (36, 4)]
-}

import Data.HashSet

%default total

data CollidingInt = MkCollidingInt Int

Eq CollidingInt where
  (==) (MkCollidingInt i) (MkCollidingInt j) = i == j

Hash CollidingInt where
  hash (MkCollidingInt i) = assert_total (prim__zextInt_B32 (mod i 39))

Show CollidingInt where
  show (MkCollidingInt i) = show i

Cell : Type
Cell = (Int, Int)

Cells : Type
Cells = HashSet Cell

gosperGun : Cells
gosperGun = fromList
  [(1,5),  (1,6),  (2,5),  (2,6),
   (11,5), (11,6), (11,7), (12,4), (12,8),
   (13,3), (13,9), (14,3), (14,9), (15,6),
   (16,4), (16,8), (17,5), (17,6), (17,7), (18,6),
   (21,3), (21,4), (21,5), (22,3), (22,4), (22,5),
   (23,2), (23,6), (25,1), (25,2), (25,6), (25,7),
   (35,3), (36,3), (35,4), (36,4)]

for : Monad m => HashSet a -> (a -> m b) -> m (List b)
for xs f = foldM (\acc, e => (:: acc) <$> f e) [] xs

main : IO ()
main = do
  let keys = MkCollidingInt <$> [0, 5..1024]
  let set = foldl (flip insert) (the (HashSet CollidingInt) empty) keys
  printLn (length set)
  printLn (filter (not . flip member set) keys)
  printLn (all (flip member set) keys)
  printLn (all (not . flip member set) (MkCollidingInt <$> [1024, 1033..2048]))

  let cells = gosperGun
  printLn (length cells)
  ls <- for cells pure
  printLn (sort ls)

-- Local Variables:
-- idris-load-packages: ("cil")
-- End:


module Cursor

import Data.Fin
import MaybeFin

import Movement

%default total
%access public

private
crimp : Fin (S (S n)) -> Fin (S n)
crimp x =
  case (strengthen x) of
       Left _ => last
       Right x' => x'

private
boundedSubtract : Fin (S k) -> Nat -> Fin (S k)
boundedSubtract FZ _ = FZ
boundedSubtract (FS x) Z = (FS x)
boundedSubtract (FS x) (S k) = boundedSubtract (weaken x) k

private
boundedAdd : Fin (S k) -> Nat -> Fin (S k)
boundedAdd x Z = x
boundedAdd x (S k) =
  case strengthen x of
       Left _ => x
       Right x' => boundedAdd (FS x') k

record Cursor (bottomRow : Nat) where
  constructor Cursor'
  rowIndex : Fin (S bottomRow)
  colIndex : Nat

%name Cursor cursor

zeroCursor : Cursor n
zeroCursor = Cursor' FZ Z

private
updateColIndex : (Nat -> Nat) -> Cursor n -> Cursor n
updateColIndex update cursor = record { colIndex = update $ colIndex cursor } cursor

private
updateRowIndex : (Fin (S n) -> Fin (S m)) -> Cursor n -> Cursor m
updateRowIndex update (Cursor' rowIndex colIndex) = Cursor' (update rowIndex) colIndex

private
natToNullableFin : Nat -> MaybeFin n
natToNullableFin {n = Z} _ = NoFin
natToNullableFin {n = (S _)} k = SomeFin $ fromMaybe last $ natToFin k _

columnCursor : Cursor _ -> MaybeFin n
columnCursor (Cursor' _ colIndex) = natToNullableFin colIndex

private
moveByCharInLine : Move ByCharacter -> Nat -> Nat -> Nat
moveByCharInLine movement Z colIndex = colIndex
moveByCharInLine (Backward move) (S k) colIndex = minus colIndex move
moveByCharInLine (Forward move) (S k) colIndex =
  case natToFin colIndex (S k) of
       Nothing => colIndex
       Just fin => finToNat $ boundedAdd fin move

moving_within_empty_line_is_idempotent : moveByCharInLine move Z colIndex = colIndex
moving_within_empty_line_is_idempotent = Refl

-- TODO further proofs here once I understand how

moveByChar : Move ByCharacter -> Nat -> Cursor n -> Cursor n
moveByChar movement lineLength =
  updateColIndex $ moveByCharInLine movement lineLength

private
moveRowCursorByLine : Move ByLine -> Fin (S n) -> Fin (S n)
moveRowCursorByLine (Backward k) rowCursor =
  boundedSubtract rowCursor k
moveRowCursorByLine (Forward k) rowCursor =
  boundedAdd rowCursor k

moveByLine : Move ByLine -> Cursor v -> Cursor v
moveByLine movement =
  updateRowIndex $ moveRowCursorByLine movement

deleteLine : Cursor (S n) -> Cursor n
deleteLine = updateRowIndex crimp

insertLineAbove : Cursor n -> Cursor (S n)
insertLineAbove = updateRowIndex weaken

-- TODO should actually truncate to end of line here
insertAfter : Nat -> Cursor n -> Cursor n
insertAfter n = updateColIndex (+ n)

-- TODO should actually behave differently than insertAfter
insertBefore : Nat -> Cursor n -> Cursor n
insertBefore k = updateColIndex (+ n)


||| WIP: same as Data.List.Quantifiers but for lazy lists

module Data.List.Lazy.Quantifiers

import Data.DPair
import Data.List.Lazy

%default total

namespace Any

  -- Note: it is crucial here that we mark `xs` as `Lazy`, otherwise Idris
  --  will happily use `Delay` in the return index and give us a badly-behaved
  -- family!
  public export
  data Any : (p : a -> Type) -> (xs : LazyList a) -> Type where
    Here : {0 xs : Lazy (LazyList a)} -> p x -> Any p (x :: xs)
    There : {0 xs : Lazy (LazyList a)} -> Any p xs -> Any p (x :: xs)

  public export
  toExists : Any p xs -> Exists p
  toExists (Here prf) = Evidence _ prf
  toExists (There p) = toExists p

  public export
  toDPair : {xs : LazyList a} -> Any p xs -> DPair a p
  toDPair (Here prf) = (_ ** prf)
  toDPair (There p) = toDPair p


import Providers
-- import Data.HVect
-- import Data.Fin

%default total
%language TypeProviders

-- Enumerating observations, in order to be able to reason about
-- sequences, and to avoid introducing contradictory types.

-- Assumptions could depend on a few observations at once, so
-- something like lists of observations should be used instead of
-- single ones, and checks against permutations then, perhaps.

-- #, input, output
postulate blackbox : Integer -> Integer -> Integer

partial parseDigit : Char -> Integer
parseDigit '0' = 0
parseDigit '1' = 1
parseDigit '2' = 2
parseDigit '3' = 3
parseDigit '4' = 4
parseDigit '5' = 5
parseDigit '6' = 6
parseDigit '7' = 7
parseDigit '8' = 8
parseDigit '9' = 9

partial parseInt : String -> Integer
parseInt s = foldl (\x,y => 10*x + parseDigit y) 0 (unpack s)

partial parseState : String -> (Integer, Integer)
parseState s = case (words s) of
  [w1, w2] => (parseInt w1, parseInt w2)

partial experiment : Integer -> IO (Provider Type)
experiment inp = do
  val <- readFile "/tmp/black-box-test"
  (n, out) <- return $ parseState val
  fh <- openFile "/tmp/black-box-test" Write
  fwrite fh $ show (n + 1) ++ " " ++ show (out + inp)
  closeFile fh
  return (Provide (blackbox (n + 1) inp = (out + inp)))

%provide (first : Type) with (experiment 2)
%provide (second : Type) with (experiment 4)
%provide (third : Type) with (experiment 1)

alwaysIncreases' : blackbox num1 inp1 = out1 -> blackbox num2 inp2 = out2 -> Type
alwaysIncreases' {num1} {num2} {out1} {out2} b1 b2 = (if num1 <= num2 then out1 <= out2 else out2 <= out1) = True

increasesByInput' : blackbox num1 inp1 = out1 -> blackbox num2 inp2 = out2 -> Type
increasesByInput' {num1} {num2} {inp1} {inp2} {out1} {out2} b1 b2 = case (num1 == num2 - 1) of
  True => out2 = out1 + inp2
  False => case (num1 == num2 + 1) of
    True => out1 = out2 + inp1
    False => Unit

c1IncreasesByInput' : (b1:first) -> (b2:second) -> increasesByInput' b1 b2
c1IncreasesByInput' b1 b2 = Refl

c2IncreasesByInput' : (b1:first) -> (b2:second) -> increasesByInput' b2 b1
c2IncreasesByInput' b1 b2 = Refl

c3IncreasesByInput' : (b1:first) -> (b3:third) -> increasesByInput' b1 b3
c3IncreasesByInput' b1 b3 = MkUnit


module Data.List1

%default total

infixr 7 :::

public export
record List1 a where
  constructor (:::)
  head : a
  tail : List a

------------------------------------------------------------------------
-- Conversion

||| Forget that a list is non-empty
public export
forget : (1 xs : List1 a) -> List a
forget (x ::: xs) = x :: xs

||| Check whether a list is non-empty
export
fromList : (1 xs : List a) -> Maybe (List1 a)
fromList [] = Nothing
fromList (x :: xs) = Just (x ::: xs)

------------------------------------------------------------------------
-- Basic functions

public export
singleton : (1 x : a) -> List1 a
singleton a = a ::: []

export
last : List1 a -> a
last (x ::: xs) = loop x xs where

  loop : a -> List a -> a
  loop x [] = x
  loop _ (x :: xs) = loop x xs

export
foldr1' : (a -> b -> b) -> (a -> b) -> List1 a -> b
foldr1' c n (x ::: xs) = loop x xs where

  loop : a -> List a -> b
  loop a [] = n a
  loop a (x :: xs) = c a (loop x xs)

export
foldr1 : (a -> a -> a) -> List1 a -> a
foldr1 c = foldr1' c id

export
foldl1 : (a -> b) -> (b -> a -> b) -> List1 a -> b
foldl1 n c (x ::: xs) = foldl c (n x) xs

------------------------------------------------------------------------
-- Append

export
appendl : (1 xs : List1 a) -> (1 ys : List a) -> List1 a
appendl (x ::: xs) ys = x ::: xs ++ ys

export
append : (1 xs, ys : List1 a) -> List1 a
append xs ys = appendl xs (forget ys)

export
lappend : (1 xs : List a) -> (1 ys : List1 a) -> List1 a
lappend [] ys = ys
lappend (x :: xs) ys = append (x ::: xs) ys

------------------------------------------------------------------------
-- Cons/Snoc

public export
cons : (1 x : a) -> (1 xs : List1 a) -> List1 a
cons x xs = x ::: forget xs

export
snoc : (1 xs : List1 a) -> (1 x : a) -> List1 a
snoc xs x = append xs (singleton x)

------------------------------------------------------------------------
-- Reverse

public export
reverseOnto : (1 acc : List1 a) -> (1 xs : List a) -> List1 a
reverseOnto acc [] = acc
reverseOnto acc (x :: xs) = reverseOnto (x ::: forget acc) xs

public export
reverse : (1 xs : List1 a) -> List1 a
reverse (x ::: xs) = reverseOnto (singleton x) xs

------------------------------------------------------------------------
-- Instances

export
Semigroup (List1 a) where
  (<+>) = append

export
Functor List1 where
  map f (x ::: xs) = f x ::: map f xs

export
Applicative List1 where
  pure x = singleton x
  f ::: fs <*> xs = appendl (map f xs) (fs <*> forget xs)

export
Monad List1 where
  (x ::: xs) >>= f = appendl (f x) (xs >>= forget . f)

export
Foldable List1 where
  foldr c n (x ::: xs) = c x (foldr c n xs)

export
Show a => Show (List1 a) where
  show = show . forget

export
Eq a => Eq (List1 a) where
  (x ::: xs) == (y ::: ys) = x == y && xs == ys

export
Ord a => Ord (List1 a) where
  compare xs ys = compare (forget xs) (forget ys)

------------------------------------------------------------------------
-- Properties

export
consInjective : the (List1 a) (x ::: xs) === (y ::: ys) -> (x === y, xs === ys)
consInjective Refl = (Refl, Refl)


||| Additional functions about vectors
module Data.Vect.Extra

import Data.Vect
import Data.Fin
import Data.Vect.Elem

||| Version of `map` with access to the current position
public export
mapWithPos : (f : Fin n -> a -> b) -> Vect n a -> Vect n b
mapWithPos f [] = []
mapWithPos f (x :: xs) = f 0 x :: mapWithPos (f . FS) xs

||| Version of `map` with runtime-irrelevant information that the
||| argument is an element of the vector
public export
mapWithElem : (xs : Vect n a)
  -> (f : (x : a) -> (0 pos : x `Elem` xs) -> b)
  -> Vect n b
mapWithElem []        f = []
mapWithElem (x :: xs) f
  = f x Here :: mapWithElem xs
                (\x,pos => f x (There pos))


module Control.Monad.Id

%default total
%access public export

data Id : (a : Type)-> Type where
  IdF : (x : a) -> Id a

implementation Functor Id where
  map f (IdF a) = IdF (f a)

implementation Applicative Id where
    pure a = IdF a
    (IdF f) <*> (IdF a) = IdF $ f a

implementation Monad Id where
  (IdF x) >>= f = f x

implementation (Show a)=>Show (Id a) where
  show (IdF a) = show a


nats : List Nat -> List Nat
nats = the (List Nat)

singletonRange : nats [1..1] = nats [1]
singletonRange = Refl

basicIncreasingRange : nats [1..3] = nats [1, 2 , 3]
basicIncreasingRange = Refl

basicDecreasingRange : nats [3..1] = nats [3, 2, 1]
basicDecreasingRange = Refl

increasingRangeWithStep : nats [3, 5..11] = nats [3, 5, 7, 9, 11]
increasingRangeWithStep = Refl

increaingRangeWithStepEmpty : nats [3, 5..1] = nats []
increaingRangeWithStepEmpty = Refl

singletonRangeWithStep : nats [3, 4..3] = nats [3]
singletonRangeWithStep = Refl

zeroStepEmptyList : nats [3, 3..5] = nats []
zeroStepEmptyList = Refl

zeroStepWhenBoundEqual : nats [1, 1..1] = nats [1]
zeroStepWhenBoundEqual = Refl

decreasingRangeWithStep : nats [11, 8..1] = nats [11, 8, 5, 2]
decreasingRangeWithStep = Refl

decreasingRangeWithStepEmpty : nats [9, 8..10] = nats []
decreasingRangeWithStepEmpty = Refl

decreasingSingletonRangeWithStep : nats [9, 8..9] = nats [9]
decreasingSingletonRangeWithStep = Refl


import Data.Vect

my_length : List a -> Nat
my_length [] = 0
my_length (x :: xs) = 1 + my_length xs

my_reverse : List a -> List a
my_reverse [] = []
my_reverse (x :: xs) = (my_reverse xs) ++ [x]

my_map : (a -> b) -> List a -> List b
my_map f [] = []
my_map f (x :: xs) = f x :: my_map f xs

my_map2 : (a -> b) -> Vect n a -> Vect n b
my_map2 f [] = []
my_map2 f (x :: xs) = f x :: my_map2 f xs


module Parcomb

data Parser a = MkParser (Lazy (String -> (Maybe a, String)))

parse : Parser a -> String -> (Maybe a, String)
parse p = case p of
  MkParser x => x

class Applicative f => LazyAlternative (f : Type -> Type) where
    empty : f a
    alt : Lazy (f a) -> Lazy (f a) -> f a

instance Functor Parser where
  map f p = MkParser $ \str => case (parse p str) of
    (Nothing, rest) => (Nothing, rest)
    (Just x, rest) => (Just (f x), rest)

mutual
  instance Applicative Parser where
    pure a = MkParser $ \str => (Just a, str)
    mf <$> mp = do
      p <- mp
      f <- mf
      return (f p)

  instance Monad Parser where
    p >>= g = MkParser $ \str => case (parse p str) of
      (Nothing, rest) => (Nothing, rest)
      (Just x, rest) => parse (g x) rest

instance LazyAlternative Parser where
  empty = MkParser $ \str => (Nothing, str)
  alt f s = MkParser $ \str => case (parse f str) of
    (Nothing, rest) => parse s str
    (Just x, rest) => (Just x, rest)

fail : Parser a
fail = MkParser $ \str => (Nothing, "")

item : Parser Char
item = MkParser $ \str =>
  case str of
    "" => (Nothing, "")
    _ => (Just (strHead str), strTail str)

sat : (Char -> Bool) -> Parser Char
sat p = do
  c <- item
  if p c
  then return c
  else fail

char : Char -> Parser Char
char c = sat (c ==)

string : String -> Parser String
string "" = return ""
string str = do
  char c
  string cs
  return str
where c = strHead str
      cs = strTail str

mutual
  many : Parser a -> (Parser (List a))
  many p = alt (some p) (return [])

  some : Parser a -> (Parser (List a))
  some p = do
    a <- p
    as <- many p
    return (a :: as)

namespace Main
  main : IO ()
  main = putStrLn . show $ parse (many $ char 'p') "pppa"


import Data.List.Views

-- total
isSuffix : Eq a => List a -> List a -> Bool
isSuffix input1 input2 with (MkPair (snocList input1) (snocList input2))
  isSuffix [] input2 | (Empty, s) = True
  isSuffix input1 [] | (s, Empty) = False
  isSuffix (xs ++ [x]) (ys ++ [y]) | (MkPair (Snoc x xs xsrec) (Snoc y ys ysrec))
     = if x == y
          then isSuffix xs ys | (MkPair xsrec ysrec)
          else False


module Data.Tree

import Data.List
import Data.List1
import Data.String

%default total

--------------------------------------------------------------------------------
--          Finite Trees
--------------------------------------------------------------------------------

mutual

  ||| A finite rose tree
  public export
  record Tree (a : Type) where
    constructor MkTree
    value : a
    forest : Forest a

  ||| A finite forest of trees
  public export
  Forest : Type -> Type
  Forest = List . Tree

--------------------------------------------------------------------------------
--          Creating Trees
--------------------------------------------------------------------------------

public export
singleton : a -> Tree a
singleton a = MkTree a []

public export
replicate : (width : Nat) -> (depth : Nat) -> a -> Tree a
replicate _         0 x = MkTree x []
replicate width (S k) x = MkTree x $ replicate width (replicate width k x)

||| Unfold a tree up to the given depth.
public export
unfold : (depth : Nat) -> (f : s -> (a,List s)) -> s -> Tree a
unfold 0     f s = MkTree (fst $ f s) []
unfold (S k) f s = let (a,ss) = f s
                    in MkTree a (map (unfold k f) ss)

--------------------------------------------------------------------------------
--          Flattening Trees
--------------------------------------------------------------------------------

zipWithKeep : (a -> a -> a) -> List a -> List a -> List a
zipWithKeep f [] ys = ys
zipWithKeep f xs [] = xs
zipWithKeep f (x :: xs) (y :: ys) = f x y :: zipWithKeep f xs ys

public export
flatten : Tree a -> List a
flatten (MkTree v vs) = v :: flattenF vs
  where flattenF : Forest a -> List a
        flattenF []        = Nil
        flattenF (x :: xs) = flatten x ++ flattenF xs

public export
layers : Tree a -> List (List a)
layers (MkTree v vs) = [v] :: layersF vs
  where layersF : Forest a -> List (List a)
        layersF []        = Nil
        layersF (x :: xs) = zipWithKeep (++) (layers x) (layersF xs)

--------------------------------------------------------------------------------
--          Accessing Elements
--------------------------------------------------------------------------------

public export
index : List Nat -> Tree a -> Maybe a
index []        x = Just x.value
index (y :: ys) x = ix y x.forest >>= index ys
  where ix : Nat -> List b -> Maybe b
        ix _ []            = Nothing
        ix 0     (z :: _)  = Just z
        ix (S k) (_ :: zs) = ix k zs

--------------------------------------------------------------------------------
--          Functor and Monad Implementations
--------------------------------------------------------------------------------

-- All implementations are boilerplaty to satisfy the totality checker.
foldlTree : (a -> e -> a) -> a -> Tree e -> a
foldlTree f acc (MkTree v vs) = foldlF (f acc v) vs
  where foldlF : a -> Forest e -> a
        foldlF y []        = y
        foldlF y (x :: xs) = foldlF (foldlTree f y x) xs

foldrTree : (e -> a -> a) -> a -> Tree e -> a
foldrTree f acc (MkTree v vs) = f v (foldrF acc vs)
  where foldrF : a -> Forest e -> a
        foldrF y []        = y
        foldrF y (x :: xs) = foldrTree f (foldrF y xs) x

traverseTree : Applicative f => (a -> f b) -> Tree a -> f (Tree b)
traverseTree fun (MkTree v vs) = [| MkTree (fun v) (traverseF vs) |]
  where traverseF : Forest a -> f (Forest b)
        traverseF []        = pure []
        traverseF (x :: xs) = [| traverseTree fun x :: traverseF xs |]

mapTree : (a -> b) -> Tree a -> Tree b
mapTree f (MkTree v vs) = MkTree (f v) (mapF vs)
  where mapF : Forest a -> Forest b
        mapF []       = []
        mapF (h :: t) = mapTree f h :: mapF t

bindTree : Tree a -> (a -> Tree b) -> Tree b
bindTree (MkTree va tas) f =
  let MkTree vb tbs = f va
   in MkTree vb (tbs ++ bindF tas)

  where bindF : Forest a -> Forest b
        bindF []        = []
        bindF (x :: xs) = bindTree x f :: bindF xs

apTree : Tree (a -> b) -> Tree a -> Tree b
apTree tf ta = bindTree tf $ \f => mapTree (apply f) ta

joinTree : Tree (Tree a) -> Tree a
joinTree (MkTree (MkTree va tas) ftas) =
  MkTree va $ tas ++ joinF ftas

  where joinF : Forest (Tree a) -> Forest a
        joinF []        = []
        joinF (x :: xs) = joinTree x :: joinF xs

eqTree : Eq a => Tree a -> Tree a -> Bool
eqTree (MkTree x xs) (MkTree y ys) = x == y && eqF xs ys
  where eqF : Forest a -> Forest a -> Bool
        eqF [] []       = True
        eqF [] (_ :: _) = False
        eqF (_ :: _) [] = False
        eqF (x :: xs) (y :: ys) = eqTree x y && eqF xs ys

--------------------------------------------------------------------------------
--          Visualizing Trees
--------------------------------------------------------------------------------

export
drawTree : Tree String -> String
drawTree  = unlines . draw
  where
    drawForest : Forest String -> String
    drawForest  = unlines . map drawTree

    draw : Tree String -> List String
    draw (MkTree x ts0) = lines x ++ subTrees ts0
      where
        shift : String -> String -> List String -> List String
        shift first other tails =
          zipWith (++) (first :: replicate (length tails) other) tails

        subTrees : Forest String -> List String
        subTrees []      = []
        subTrees [t]     = "│" :: shift "└╼" "  " (draw t)
        subTrees (t::ts) = "│" :: shift "├╼" "│ " (draw t) ++ subTrees ts

--------------------------------------------------------------------------------
--          Interfaces
--------------------------------------------------------------------------------

public export %inline
Eq a => Eq (Tree a) where
  (==) = eqTree

public export %inline
Foldable Tree where
  foldl  = foldlTree
  foldr  = foldrTree
  null _ = False

public export %inline
Functor Tree where
  map = mapTree

public export %inline
Applicative Tree where
  pure a = MkTree a Nil
  (<*>)  = apTree

public export %inline
Monad Tree where
  (>>=) = bindTree
  join  = joinTree

public export %inline
Traversable Tree where
  traverse = traverseTree


           module UninhIndent

           data MyElem : a -> List a -> Type where
             MyHere : MyElem x (x :: xs)
             MyThere : (later : MyElem x xs) -> MyElem x (y :: xs)

           Uninhabited (MyElem a []) where
             uninhabited c = ?uninhabited_rhs


module Graphics.Util.Mesh

import Data.Vect

%access public export
%default total
Vec2 : Type
Vec2 = Vect 2 Double

Vec3 : Type
Vec3 = Vect 3 Double

Vec4 : Type
Vec4 = Vect 4 Double

||| a data type for meshes.
|||
||| a mesh is a collection of positions, of UV texture coordinates, vertex normals and indices
|||
data Mesh : Type where
  UvMesh :  (positions: Vect n Vec3)
         -> (normals: Vect n Vec3)
         -> (uvs: Vect n Vec2)
         -> (indices: List Int)
         -> Mesh

positions : Mesh -> List Vec3
positions (UvMesh p _ _ _) = toList p

indices : Mesh -> List Int
indices (UvMesh _ _ _ xs) = xs


||| Axioms and propsitions for primitive types with an
||| `Ord` implementation.
module Data.Prim.Ord

import public Data.Trichotomy

%default total

||| Similar to `Either` but with erased fields.
public export
data Either0 : Type -> Type -> Type where
  Left0  : (0 v : a) -> Either0 a b
  Right0 : (0 v : b) -> Either0 a b

||| We often don't trust values of type `a === b`, as they might
||| have been magically crafted using `believe_me` or `assert_total`
||| followed by `idris_crash`. If a value of another type follows
||| from a (potentially) magically crafted one, we only want the
||| second value to reduce at compile time, if the first value
||| reduces to `Refl`. Otherwise, we risk blowing up the compiler
||| in an absurd context.
export
strictRefl : (0 prf : a === b) -> Lazy c -> c
strictRefl Refl x = x

--------------------------------------------------------------------------------
--          Interface
--------------------------------------------------------------------------------

||| This interface is a witness that the given primitive type
||| comes with a relation `lt`, with `lt` being a strict total order.
||| We typically define the following aliases
||| (or name the relation accordingly):
|||
|||   `m < n`  := lt m n
|||   `m > n`  := lt n m
|||   `m <= n` := Either (lt m n) (m === n)
|||   `m >= n` := Either (lt n m) (n === m)
|||   `m /= n` := Either (lt m n) (lt n m)
|||
||| The following axioms must hold:
|||   1. (<) is transitive: From `k < m` and `m < n` follows `k < n`.
|||
|||   2. Trichotomy: For all values `m` and `n` exactly one of the
|||      following holds: `m < n`, `m === n`, or `n < m`.
|||
||| It is in the nature of a primitive that we can't proof these axioms
||| in Idris itself. We must therefore assume that they hold on all backends,
||| and it is the responsibility of programmers implementing
||| interface `Total` to make sure that the axioms actually hold.
public export
interface Total (0 a : Type) (0 lt : a -> a -> Type) | lt where
  ||| Axiom I: `<` is transitive.
  0 transLT : {k,m,n : a} -> lt k m -> lt m n -> lt k n

  ||| Axiom II: Trichotomy of `<`, `===`, and `>`.
  trichotomy : (m,n : a) -> Trichotomy lt m n

||| Tests if the first value is strictly less than the second or not
export
testLT : Total a lt => (x,y : a) -> Either0 (lt x y) (Either (lt y x) (y === x))
testLT x y = case trichotomy {lt} x y of
  LT p _ _ => Left0 p
  EQ _ p _ => Right0 (Right $ sym p)
  GT _ _ p => Right0 (Left p)

||| Tests if the first value is strictly greater than the second or not
export
testGT : Total a lt => (x,y : a) -> Either0 (lt y x) (Either (lt x y) (x === y))
testGT x y = case trichotomy {lt} x y of
  GT _ _ p => Left0 p
  LT p _ _ => Right0 (Left p)
  EQ _ p _ => Right0 (Right p)

||| Tests if the two values are provably equal or not
export
testEQ : Total a lt => (x,y : a) -> Either0 (x === y) (Either (lt x y) (lt y x))
testEQ x y = case trichotomy {lt} x y of
  EQ _ p _ => Left0 p
  LT p _ _ => Right0 (Left p)
  GT _ _ p => Right0 (Right p)

--------------------------------------------------------------------------------
--          Corollaries
--------------------------------------------------------------------------------

||| `<` is irreflexive.
export
0 irrefl : Total a lt => Not (lt m m)
irrefl x = case trichotomy m m of
  LT y _ f => f y
  EQ f _ _ => f x
  GT f _ y => f y

--------------------------------------------------------------------------------
--          Transitivities
--------------------------------------------------------------------------------

namespace LT

  ||| This is an alias for `transLT`
  export
  0 trans : Total a lt => lt k m -> lt m n -> lt k n
  trans = transLT

||| `k === m` and `m /= n` implies `k /= n`.
export
0 trans_EQ_NEQ :  Total a lt
               => k === m
               -> Either (lt m n) (lt n m)
               -> Either (lt k n) (lt n k)
trans_EQ_NEQ eqv neq  = rewrite eqv in neq

||| `k === m` and `m /= n` implies `k /= n`.
export
0 trans_NEQ_EQ :  Total a lt
               => Either (lt k m) (lt m k)
               -> m === n
               -> Either (lt k n) (lt n k)
trans_NEQ_EQ neq eqv = rewrite (sym eqv) in neq

||| `k < m` and `m === n` implies `k < n`
export
0 trans_LT_EQ : Total a lt => lt k m -> m === n -> lt k n
trans_LT_EQ p eqv = rewrite sym eqv in p

||| `k === m` and `m < n` implies `k < n`
export
0 trans_EQ_LT : Total a lt => k === m -> lt m n -> lt k n
trans_EQ_LT eqv q = rewrite eqv in q

||| `k <= m` and `m < n` implies `k < n`
export
0 trans_LTE_LT : Total a lt => Either (lt k m) (k === m) -> lt m n -> lt k n
trans_LTE_LT x y = either (`trans` y) (`trans_EQ_LT` y) x

||| `k < m` and `m <= n` implies `k < n`
export
0 trans_LT_LTE : Total a lt => lt k m -> Either (lt m n) (m === n) -> lt k n
trans_LT_LTE x = either (trans x) (trans_LT_EQ x)

||| `k > m` and `m === n` implies `k > n`
export
0 trans_GT_EQ : Total a lt => lt m k -> m === n -> lt n k
trans_GT_EQ p eqv = rewrite sym eqv in p

||| `k === m` and `m > n` implies `k > n`
export
0 trans_EQ_GT : Total a lt => k === m -> lt n m -> lt n k
trans_EQ_GT eqv q = rewrite eqv in q

||| `k >= m` and `m > n` implies `k > n`
export
0 trans_GTE_GT : Total a lt => Either (lt m k) (m === k) -> lt n m -> lt n k
trans_GTE_GT x y = either (trans y) (\v => trans_EQ_GT (sym v) y) x

||| `k > m` and `m >= n` implies `k > n`
export
0 trans_GT_GTE : Total a lt => lt m k -> Either (lt n m) (n === m) -> lt n k
trans_GT_GTE x (Left y)  = trans y x
trans_GT_GTE x (Right y) = trans_GT_EQ x (sym y)

namespace LTE

  ||| `<=` is reflexive.
  export
  0 refl : Total a lt => Either (lt m m) (m === m)
  refl = Right Refl

  ||| `<=` is transitive.
  export
  0 trans :  Total a lt
          => Either (lt k m) (k === m)
          -> Either (lt m n) (m === n)
          -> Either (lt k n) (k === n)
  trans (Left x)  y         = Left (trans_LT_LTE x y)
  trans (Right x) (Left y)  = Left (trans_EQ_LT x y)
  trans (Right x) (Right y) = Right (trans x y)

  ||| `<=` is antisymmetric.
  export
  0 antisym :  Total a lt
            => Either (lt m n) (m === n)
            -> Either (lt n m) (m === n)
            -> m === n
  antisym (Right x) _         = x
  antisym (Left x)  (Right y) = y
  antisym (Left x)  (Left y)  = void (irrefl $ trans x y)

||| `k <= m` and `m === n` implies `k <= n`
export
0 trans_LTE_EQ :  Total a lt
               => Either (lt k m) (k === m)
               -> m === n
               -> Either (lt k n) (k === n)
trans_LTE_EQ lte eq = trans lte (Right eq)

||| `k === m` and `m <= n` implies `(k <= n)`
export
0 trans_EQ_LTE :  Total a lt
               => k === m
               -> Either (lt m n) (m === n)
               -> Either (lt k n) (k === n)
trans_EQ_LTE eq lte = trans (Right eq) lte

namespace GTE

  ||| `>=` is transitive.
  export
  0 trans :  Total a lt
          => Either (lt m k) (m === k)
          -> Either (lt n m) (n === m)
          -> Either (lt n k) (n === k)
  trans (Left x)  y         = Left (trans_GT_GTE x y)
  trans (Right x) (Left y)  = Left (trans_EQ_GT (sym x) y)
  trans (Right x) (Right y) = Right (trans y x)

  ||| `>=` is antisymmetric.
  export
  0 antisym :  Total a lt
            => Either (lt n m) (m === n)
            -> Either (lt m n) (m === n)
            -> m === n
  antisym (Right x) _         = x
  antisym (Left x)  (Right y) = y
  antisym (Left x)  (Left y)  = void (irrefl $ trans x y)

||| `k >= m` and `m === n` implies `k >= n`
export
0 trans_GTE_EQ :  Total a lt
               => Either (lt m k) (m === k)
               -> m === n
               -> Either (lt n k) (n === k)
trans_GTE_EQ gte eq = trans gte (Right $ sym eq)

||| `k === m` and `m <= n` implies `(k <= n)`
export
0 trans_EQ_GTE :  Total a lt
               => k === m
               -> Either (lt n m) (n === m)
               -> Either (lt n k) (n === k)
trans_EQ_GTE eq gte = trans (Right $ sym eq) gte

--------------------------------------------------------------------------------
--          Conversions
--------------------------------------------------------------------------------

||| `m < n` implies `Not (m > n)`.
export
0 LT_not_GT : Total a lt => lt m n -> Not (lt n m)
LT_not_GT isLT isGT = case trichotomy m n of
  LT _ _ g => g isGT
  EQ _ _ g => g isGT
  GT f _ _ => f isLT

||| `m < n` implies `Not (m === n)`.
export
0 LT_not_EQ : Total a lt => lt m n -> Not (m === n)
LT_not_EQ isLT isEQ = case trichotomy m n of
  LT _ g _ => g isEQ
  EQ f _ _ => f isLT
  GT _ g _ => g isEQ

||| `m < n` implies `Not (m >= n)`.
export
0 LT_not_GTE : Total a lt => lt m n -> Not (Either (lt n m) (n === m))
LT_not_GTE l = either (LT_not_GT l) (\e => LT_not_EQ l (sym e))

||| `Not (m < n)` implies `m >= n`.
export
0 Not_LT_to_GTE : Total a lt => Not (lt m n) -> Either (lt n m) (n === m)
Not_LT_to_GTE f = case trichotomy m n of
  LT x _ _ => void (f x)
  EQ _ x _ => Right (sym x)
  GT _ _ x => Left x

||| `m === n` implies `Not (m < n)`.
export
0 EQ_not_LT : Total a lt => m === n -> Not (lt m n)
EQ_not_LT = flip LT_not_EQ

||| `m === n` implies `Not (m > n)`.
export
0 EQ_not_GT : Total a lt => m === n -> Not (lt n m)
EQ_not_GT isEQ = EQ_not_LT (sym isEQ)

||| `m === n` implies `Not (m /= n)`.
export
0 EQ_not_NEQ : Total a lt => m === n -> Not (Either (lt m n) (lt n m))
EQ_not_NEQ isEQ = either (EQ_not_LT isEQ) (EQ_not_GT isEQ)

||| `Not (m < n)` implies `m /= n`.
export
0 Not_EQ_to_NEQ : Total a lt => Not (m === n) -> Either (lt m n) (lt n m)
Not_EQ_to_NEQ f = case trichotomy m n of
  LT x _ _ => Left x
  EQ _ x _ => void (f x)
  GT _ _ x => Right x

||| `m > n` implies `Not (m < n)`.
export
0 GT_not_LT : Total a lt => lt n m -> Not (lt m n)
GT_not_LT = LT_not_GT

||| `m > n` implies `Not (m === n)`.
export
0 GT_not_EQ : Total a lt => lt n m -> Not (m === n)
GT_not_EQ = flip EQ_not_GT

||| `m > n` implies `Not (m <= n)`.
export
0 GT_not_LTE : Total a lt => lt n m -> Not (Either (lt m n) (m === n))
GT_not_LTE gt = either (GT_not_LT gt) (GT_not_EQ gt)

||| `Not (m > n)` implies `m <= n`.
export
0 Not_GT_to_LTE : Total a lt => Not (lt n m) -> Either (lt m n) (m === n)
Not_GT_to_LTE f = case trichotomy m n of
  LT x _ _ => Left x
  EQ _ x _ => Right x
  GT _ _ x => void (f x)

||| `m <= n` implies `Not (m > n)`.
export
0 LTE_not_GT : Total a lt => (Either (lt m n) (m === n)) -> Not (lt n m)
LTE_not_GT = either LT_not_GT EQ_not_GT

||| `Not (m <= n)` implies `m > n`.
export
0 Not_LTE_to_GT : Total a lt => Not (Either (lt m n) (m === n)) -> lt n m
Not_LTE_to_GT f = case trichotomy m n of
  LT x _ _ => void (f $ Left x)
  EQ _ x _ => void (f $ Right x)
  GT _ _ x => x

||| `m <= n` and `m >= n` implies `m === n`.
export
0 LTE_and_GTE_to_EQ :  Total a lt
                    => Either (lt m n) (m === n)
                    -> Either (lt n m) (n === m)
                    -> m === n
LTE_and_GTE_to_EQ (Left x)  (Right y) = sym y
LTE_and_GTE_to_EQ (Right x) _         = x
LTE_and_GTE_to_EQ (Left x)  (Left y)  = void (LT_not_GT x y)

||| `m <= n` and `m /= n` implies `m < n`.
export
0 LTE_and_NEQ_to_LT :  Total a lt
                    => Either (lt m n) (m === n)
                    -> Either (lt m n) (lt n m)
                    -> lt m n
LTE_and_NEQ_to_LT (Left x)  _         = x
LTE_and_NEQ_to_LT (Right _) (Left x)  = x
LTE_and_NEQ_to_LT (Right x) (Right y) = void (EQ_not_GT x y)

||| `m /= n` implies `Not (m === n)`.
export
0 NEQ_not_EQ : Total a lt => Either (lt m n) (lt n m) -> Not (m === n)
NEQ_not_EQ = either LT_not_EQ GT_not_EQ

||| `Not (m /= n)` implies `m === n`.
export
0 Not_NEQ_to_EQ : Total a lt => Not (Either (lt m n) (lt n m)) -> m === n
Not_NEQ_to_EQ f = case trichotomy m n of
  LT x _ _ => void (f $ Left x)
  EQ _ x _ => x
  GT _ _ x => void (f $ Right x)

||| `m /= n` and `m <= n` implies `m < n`.
export
0 NEQ_and_LTE_to_LT :  Total a lt
                    => Either (lt m n) (lt n m)
                    -> Either (lt m n) (m === n)
                    -> lt m n
NEQ_and_LTE_to_LT = flip LTE_and_NEQ_to_LT

||| `m /= n` and `m <= n` implies `m < n`.
export
0 NEQ_and_GTE_to_GT :  Total a lt
                    => Either (lt m n) (lt n m)
                    -> Either (lt n m) (n === m)
                    -> lt n m
NEQ_and_GTE_to_GT (Right x) _         = x
NEQ_and_GTE_to_GT (Left _)  (Left y)  = y
NEQ_and_GTE_to_GT (Left x)  (Right y) = void (GT_not_EQ x y)

||| `m >= n` implies `Not (m < n)`.
export
0 GTE_not_LT : Total a lt => Either (lt n m) (n === m) -> Not (lt m n)
GTE_not_LT = either GT_not_LT EQ_not_GT

||| `Not (m >= n)` implies `m < n`.
export
0 Not_GTE_to_LT : Total a lt => Not (Either (lt n m) (n === m)) -> lt m n
Not_GTE_to_LT f = case trichotomy m n of
  LT x _ _ => x
  EQ _ x _ => void (f $ Right (sym x))
  GT _ _ x => void (f $ Left x)

||| `m >= n` and `m <= n` implies `m === n`.
export
0 GTE_and_LTE_to_EQ :  Total a lt
                    => Either (lt n m) (n === m)
                    -> Either (lt m n) (m === n)
                    -> m === n
GTE_and_LTE_to_EQ = flip LTE_and_GTE_to_EQ

||| `m >= n` and `m /= n` implies `m > n`.
export
0 GTE_and_NEQ_to_GT :  Total a lt
                    => Either (lt n m) (n === m)
                    -> Either (lt m n) (lt n m)
                    -> lt n m
GTE_and_NEQ_to_GT = flip NEQ_and_GTE_to_GT


-- Primitive Imperative Language --
module Example.Pil

import Data.List
import Data.List.Elem
import Data.Maybe

%default total

------------------------------------------------------
--- Auxiliary data definitions and their instances ---
------------------------------------------------------

export
data Name = MkName String

%name Name n, m

export
FromString Name where
  fromString = MkName

export
Eq Name where
  MkName n == MkName m = n == m

--- Static context in terms of which we are formulating an invariant ---

public export
Context : Type
Context = List (Name, Type)

%name Context ctx

-----------------------------------------------
--- List lookup with propositional equality ---
-----------------------------------------------

public export
data Lookup : a -> List (a, b) -> Type where
  There : Lookup z xys -> Lookup z $ (x, y)::xys
  Here : (y : b) -> Lookup x $ (x, y)::xys
  -- !!! Idris searches from the bottom !!!

public export
reveal : Lookup {b} x xys -> b
reveal (Here y) = y
reveal (There subl) = reveal subl

-----------------------------------
--- The main language structure ---
-----------------------------------

public export
data Expression : (ctx : Context) -> (res : Type) -> Type where
  -- Constant expression
  C : (x : ty) -> Expression ctx ty
  -- Value of the variable
  V : (n : Name) -> (0 ty : Lookup n ctx) => Expression ctx $ reveal ty
  -- Unary operation over the result of another expression
  U : (f : a -> b) -> Expression ctx a -> Expression ctx b
  -- Binary operation over the results of two another expressions
  B : (f : a -> b -> c) -> Expression ctx a -> Expression ctx b -> Expression ctx c

infix 2 #=, ?#=
infixr 1 *>

public export
data Statement : (pre : Context) -> (post : Context) -> Type where
  nop  : Statement ctx ctx
  (.)  : (0 ty : Type) -> (n : Name) -> Statement ctx $ (n, ty)::ctx
  (#=) : (n : Name) -> (0 ty : Lookup n ctx) => (v : Expression ctx $ reveal ty) -> Statement ctx ctx
  for  : (init : Statement outer_ctx inside_for)  -> (cond : Expression inside_for Bool)
      -> (upd  : Statement inside_for inside_for) -> (body : Statement inside_for after_body)
      -> Statement outer_ctx outer_ctx
  if__ : (cond : Expression ctx Bool) -> Statement ctx ctx_then -> Statement ctx ctx_else -> Statement ctx ctx
  (*>) : Statement pre mid -> Statement mid post -> Statement pre post
  block : Statement outer inside -> Statement outer outer
  print : Show ty => Expression ctx ty -> Statement ctx ctx

public export %inline
(>>=) : Statement pre mid -> (Unit -> Statement mid post) -> Statement pre post
a >>= f = a *> f ()

public export %inline
if_  : (cond : Expression ctx Bool) -> Statement ctx ctx_then -> Statement ctx ctx
if_ c t = if__ c t nop

public export %inline
while : Expression ctx Bool -> Statement ctx after_body -> Statement ctx ctx
while cond = for nop cond nop

-- Define with derived type and assign immediately
public export %inline
(?#=) : (n : Name) -> Expression ((n, ty)::ctx) ty -> Statement ctx $ (n, ty)::ctx
n ?#= v = ty. n *> n #= v

namespace AlternativeDefineAndAssign

  public export %inline
  (#=) : (p : (Name, Type)) -> Expression (p::ctx) (snd p) -> Statement ctx $ p::ctx
  (n, _) #= v = n ?#= v

  public export %inline
  (.) : a -> b -> (b, a)
  (.) a b = (b, a)

-------------------------
--- Examples of usage ---
-------------------------

--- Functions lifted to the expression level ---

export %inline
(+) : Expression ctx Int -> Expression ctx Int -> Expression ctx Int
(+) = B (+)

export %inline
div : Expression ctx Int -> Expression ctx Int -> Expression ctx Int
div = B div

export %inline
mod : Expression ctx Int -> Expression ctx Int -> Expression ctx Int
mod = B mod

export %inline
(<) : Expression ctx Int -> Expression ctx Int -> Expression ctx Bool
(<) = B (<)

export %inline
(>) : Expression ctx Int -> Expression ctx Int -> Expression ctx Bool
(>) = B (>)

export %inline
(==) : Eq a => Expression ctx a -> Expression ctx a -> Expression ctx Bool
(==) = B (==)

export %inline
(/=) : Eq a => Expression ctx a -> Expression ctx a -> Expression ctx Bool
(/=) = B (/=)

export %inline
(&&) : Expression ctx Bool -> Expression ctx Bool -> Expression ctx Bool
(&&) = B (\a, b => a && b) -- recoded because of laziness

export %inline
(++) : Expression ctx String -> Expression ctx String -> Expression ctx String
(++) = B (++)

export %inline
show : Show ty => Expression ctx ty -> Expression ctx String
show = U show

--- Example statements ---

simple_ass : Statement ctx $ ("x", Int)::ctx
simple_ass = do
  Int. "x"
  "x" #= C 2

lost_block : Statement ctx ctx
lost_block = do
  block $ do
    Int. "x"
    "x" #= C 2
    Int. "y" #= V "x"
    Int. "z" #= C 3
    print $ V "y" + V "z" + V "x"

some_for : Statement ctx ctx
some_for = for (do Int. "x" #= C 0; Int. "y" #= C 0) (V "x" < C 5 && V "y" < C 10) ("x" #= V "x" + C 1) $ do
             "y" #= V "y" + V "x" + C 1

--bad_for : Statement ctx ctx
--bad_for = for (do Int. "x" #= C 0; Int. "y" #= C 0)
--                (V "y")
--                  ("x" #= V "x" + C 1) $ do
--             "y" #= V "y" `div` V "x" + C 1

euc : {0 ctx : Context} -> let c = ("a", Int)::("b", Int)::ctx in Statement c $ ("res", Int)::c
euc = do
  while (V "a" /= C 0 && V "b" /= C 0) $ do
    if__ (V "a" > V "b")
      ("a" #= V "a" `mod` V "b")
      ("b" #= V "b" `mod` V "a")
  Int. "res" #= V "a" + V "b"

name_shadowing : Statement ctx ctx
name_shadowing = block $ do
  Int. "x" #= C 0
  block $ do
    Int. "x" #= C 3
    Int. "y" #= V "x" + C 2
    String. "x" #= C "foo"
    print $ V "x" ++ C "bar" ++ show (V "y")
  Int. "z" #= V "x" + C 2


module Main
import Lib
import Prelude.List as lst
import Data.List

dataset : List String
dataset = [ "The future king is the prince",
--           "Daughter is the princess.",
--           "Son is the prince.",
--           "Only a man can be a king",
--           "Only a woman can be a queen",
--           "The princess will be a queen",
--           "Queen and king rule the realm",
--           "The prince is a strong man",
--           "The princess is a beautiful woman",
--           "The royal family is the king and queen and their children",
--           "Prince is only a boy now",
           "A boy will be a man"]

index : String -> List (String, Nat) ->  Nat
index x dict = (\(Just i) => i ) $ lookup x dict

get_indices : List String -> List (String,Nat) -> List Nat
get_indices vocabs dict = foldr (\x, acc => (index x  dict)::acc) [] vocabs

zeros : List String -> List (String, Nat) -> List Double
zeros vocabs dict = replicate ( lst.length $ get_indices vocabs dict ) 0

cleaned : List String
cleaned = rawToCleaned dataset

paired : List (String, String)
paired = makeWordPairs cleaned

dict : List (String,Nat)
dict = createDictionary cleaned

input : List String
input = xss paired

target : List String
target = yss paired

zs : List Double
zs = zeros cleaned dict

ran_wht : List Double
ran_wht = replicate (length $ get_indices input dict) 0.06

xss_index : List Nat
xss_index = get_indices input dict

yss_index : List Nat
yss_index = get_indices target dict

weights : List (List Double)
weights = matrix_gen ran_wht zs

en_inputs : List (List Double)
en_inputs = oneHotEncoder xss_index zs

en_targets : List  (List Double)
en_targets = oneHotEncoder yss_index zs

bias : Double
bias = 0.3

-- TODO insertAt inserts extra zeros
main : IO ()
main = let classifier = model weights en_inputs en_targets 0.001 0.9 0.999 0.00000001 2
       in print $ classifier


module Data.List.Quantifiers

import Data.DPair

import Data.List.Elem

%default total

------------------------------------------------------------------------
-- Types and basic properties

namespace Any

  ||| A proof that some element of a list satisfies some property
  |||
  ||| @ p the property to be satisfied
  public export
  data Any : (0 p : a -> Type) -> List a -> Type where
    ||| A proof that the satisfying element is the first one in the `List`
    Here  : {0 xs : List a} -> p x -> Any p (x :: xs)
    ||| A proof that the satisfying element is in the tail of the `List`
    There : {0 xs : List a} -> Any p xs -> Any p (x :: xs)

  export
  Uninhabited (Any p Nil) where
    uninhabited (Here _) impossible
    uninhabited (There _) impossible

  export
  {0 p : a -> Type} -> Uninhabited (p x) => Uninhabited (Any p xs) => Uninhabited (Any p $ x::xs) where
    uninhabited (Here y) = uninhabited y
    uninhabited (There y) = uninhabited y

  ||| Modify the property given a pointwise function
  export
  mapProperty : (f : {0 x : a} -> p x -> q x) -> Any p l -> Any q l
  mapProperty f (Here p) = Here (f p)
  mapProperty f (There p) = There (mapProperty f p)

  ||| Given a decision procedure for a property, determine if an element of a
  ||| list satisfies it.
  |||
  ||| @ p the property to be satisfied
  ||| @ dec the decision procedure
  ||| @ xs the list to examine
  export
  any : (dec : (x : a) -> Dec (p x)) -> (xs : List a) -> Dec (Any p xs)
  any _ Nil = No uninhabited
  any p (x::xs) with (p x)
    any p (x::xs) | Yes prf = Yes (Here prf)
    any p (x::xs) | No ctra =
      case any p xs of
        Yes prf' => Yes (There prf')
        No ctra' => No $ \case
          Here px => ctra px
          There pxs => ctra' pxs

  ||| Forget the membership proof
  export
  toExists : Any p xs -> Exists p
  toExists (Here prf) = Evidence _ prf
  toExists (There prf) = toExists prf

namespace All

  ||| A proof that all elements of a list satisfy a property. It is a list of
  ||| proofs, corresponding element-wise to the `List`.
  public export
  data All : (0 p : a -> Type) -> List a -> Type where
    Nil  : All p Nil
    (::) : {0 xs : List a} -> p x -> All p xs -> All p (x :: xs)

  Either (Uninhabited $ p x) (Uninhabited $ All p xs) => Uninhabited (All p $ x::xs) where
    uninhabited @{Left  _} (px::pxs) = uninhabited px
    uninhabited @{Right _} (px::pxs) = uninhabited pxs

  ||| Modify the property given a pointwise function
  export
  mapProperty : (f : {0 x : a} -> p x -> q x) -> All p l -> All q l
  mapProperty f [] = []
  mapProperty f (p::pl) = f p :: mapProperty f pl

  ||| Modify the property given a pointwise interface function
  public export
  imapProperty : (0 i : Type -> Type)
              -> (f : {0 a : Type} -> i a => p a -> q a)
              -> {0 types : List Type}
              -> All i types => All p types -> All q types
  imapProperty i f @{[]} [] = []
  imapProperty i f @{ix :: ixs} (x :: xs) = f @{ix} x :: imapProperty i f @{ixs} xs

  ||| Forget property source for a homogeneous collection of properties
  public export
  forget : All (const type) types -> List type
  forget [] = []
  forget (x :: xs) = x :: forget xs

  ||| Given a decision procedure for a property, decide whether all elements of
  ||| a list satisfy it.
  |||
  ||| @ p the property
  ||| @ dec the decision procedure
  ||| @ xs the list to examine
  export
  all : (dec : (x : a) -> Dec (p x)) -> (xs : List a) -> Dec (All p xs)
  all _ Nil = Yes Nil
  all d (x::xs) with (d x)
    all d (x::xs) | No ctra = No $ \(p::_) => ctra p
    all d (x::xs) | Yes prf =
      case all d xs of
        Yes prf' => Yes (prf :: prf')
        No ctra' => No $ \(_::ps) => ctra' ps

  export
  zipPropertyWith : (f : {0 x : a} -> p x -> q x -> r x) ->
                    All p xs -> All q xs -> All r xs
  zipPropertyWith f [] [] = []
  zipPropertyWith f (px :: pxs) (qx :: qxs)
    = f px qx :: zipPropertyWith f pxs qxs

  export
  All Show (map p xs) => Show (All p xs) where
    show pxs = "[" ++ show' "" pxs ++ "]"
      where
        show' : String -> All Show (map p xs') => All p xs' -> String
        show' acc @{[]} [] = acc
        show' acc @{[_]} [px] = acc ++ show px
        show' acc @{_ :: _} (px :: pxs) = show' (acc ++ show px ++ ", ") pxs

  ||| A heterogeneous list of arbitrary types
  public export
  HList : List Type -> Type
  HList = All id

------------------------------------------------------------------------
-- Relationship between all and any

||| If there does not exist an element that satifies the property, then it is
||| the case that all elements do not satisfy it.
export
negAnyAll : {xs : List a} -> Not (Any p xs) -> All (Not . p) xs
negAnyAll {xs=Nil}   _ = Nil
negAnyAll {xs=x::xs} f = (f . Here) :: negAnyAll (f . There)

||| If there exists an element that doesn't satify the property, then it is
||| not the case that all elements satisfy it.
export
anyNegAll : Any (Not . p) xs -> Not (All p xs)
anyNegAll (Here ctra) (p::_)  = ctra p
anyNegAll (There np)  (_::ps) = anyNegAll np ps

||| If none of the elements satisfy the property, then not any single one can.
export
allNegAny : All (Not . p) xs -> Not (Any p xs)
allNegAny [] p = absurd p
allNegAny (np :: npxs) (Here p) = absurd (np p)
allNegAny (np :: npxs) (There p) = allNegAny npxs p

||| Given a proof of membership for some element, extract the property proof for it
public export
indexAll : Elem x xs -> All p xs -> p x
indexAll  Here     (p::_  ) = p
indexAll (There e) ( _::ps) = indexAll e ps

--- Relations between listwise `All` and elementwise `Subset` ---

||| Push in the property from the list level with element level
public export
pushIn : (xs : List a) -> (0 _ : All p xs) -> List $ Subset a p
pushIn []      []      = []
pushIn (x::xs) (p::ps) = Element x p :: pushIn xs ps

||| Pull the elementwise property out to the list level
public export
pullOut : (xs : List $ Subset a p) -> Subset (List a) (All p)
pullOut [] = Element [] []
pullOut (Element x p :: xs) = let Element ss ps = pullOut xs in Element (x::ss) (p::ps)

export
pushInOutInverse : (xs : List a) -> (0 prf : All p xs) -> pullOut (pushIn xs prf) = Element xs prf
pushInOutInverse [] [] = Refl
pushInOutInverse (x::xs) (p::ps) = rewrite pushInOutInverse xs ps in Refl

export
pushOutInInverse : (xs : List $ Subset a p) -> uncurry Quantifiers.pushIn (pullOut xs) = xs
pushOutInInverse [] = Refl
pushOutInInverse (Element x p :: xs) with (pushOutInInverse xs)
  pushOutInInverse (Element x p :: xs) | subprf with (pullOut xs)
    pushOutInInverse (Element x p :: xs) | subprf | Element ss ps = rewrite subprf in Refl


-- examples in "Type-Driven Development with Idris"
-- chapter 13, section 2, Stack part

import Data.Vect

-- check that all functions are total
%default total

data StackCmd : Type -> Nat -> Nat -> Type where
  Push : Integer -> StackCmd () height (S height)
  Pop : StackCmd Integer (S height) height
  Top : StackCmd Integer (S height) (S height)
  GetStr : StackCmd String height height
  PutStr : String -> StackCmd () height height
  Pure : ty -> StackCmd ty s s
  (>>=) : StackCmd a s1 s2 ->
          (a -> StackCmd b s2 s3) ->
          StackCmd b s1 s3

runStack : (stk : Vect inHeight Integer) ->
           StackCmd ty inHeight outHeight ->
           IO (ty, Vect outHeight Integer)
runStack stk (Push x) = pure ((), x :: stk)
runStack (x :: xs) Pop = pure (x, xs)
runStack (x :: xs) Top = pure (x, x :: xs)
runStack stk (Pure x) = pure (x, stk)
runStack stk (x >>= f) = do (res, stk') <- runStack stk x
                            runStack stk' (f res)
runStack stk GetStr = do val <- getLine
                         pure (val, stk)
runStack stk (PutStr val) = do putStr val
                               pure ((), stk)

doAdd : StackCmd () (S (S height)) (S height)
doAdd = do val1 <- Pop
           val2 <- Pop
           Push $ val1 + val2

data StackIO : Nat -> Type where
  Do : StackCmd a h1 h2 ->
       (a -> Inf (StackIO h2)) -> StackIO h1

namespace StackDo
  (>>=) : StackCmd a h1 h2 ->
          (a -> Inf (StackIO h2)) -> StackIO h1
  (>>=) = Do

data Fuel = Dry | More (Lazy Fuel)

partial
forever : Fuel
forever = More forever

run : Fuel -> Vect h Integer -> StackIO h -> IO ()
run (More fuel) stk (Do c f)
  = do (res, stk') <- runStack stk c
       run fuel stk' (f res)
run Dry stk p = pure ()

data StkInput = Number Integer
              | Add

strToInput : String -> Maybe StkInput
strToInput "" = Nothing
strToInput "add" = Just Add
strToInput x = if all isDigit (unpack x)
                then Just (Number (cast x))
                else Nothing

mutual
  tryAdd : StackIO h
  tryAdd {h = (S (S k))}
    = do doAdd
         result <- Top
         PutStr (show result ++ "\n")
         stackCalc
  tryAdd
    = do PutStr "Fewer than two items on the stack\n"
         stackCalc

  stackCalc : StackIO h
  stackCalc = do PutStr "> "
                 input <- GetStr
                 case strToInput input of
                   Nothing => do PutStr "Invalid input\n"
                                 stackCalc
                   Just (Number x) => do Push x
                                         stackCalc
                   Just Add => tryAdd

partial
main : IO ()
main = run forever [] stackCalc


module Main

import Debug.Trace

{- Image -}

imageWidth : Nat
imageWidth = 256

imageHeight : Nat
imageHeight = 256

{- Render -}

main : IO ()
main =
  do
    _ <- fPutStr stdout $ "P3\n" ++ (show imageWidth) ++ " " ++ (show imageHeight) ++ "\n255\n"
    _ <- renderRows imageHeight
    pure ()

  where

    renderCells : (i : Nat) -> (j : Nat) -> IO (Either FileError ())
    renderCells Z _ = pure (Right ())
    renderCells (S i) j = do
      let i' : Nat = minus imageWidth (i + 1)
      let r : Double = (cast i') / (cast (minus imageWidth 1))
      let g : Double = (cast j) / (cast (minus imageHeight 1))
      let b : Double = 0.25

      let ir : Int = cast (255.99 * r)
      let ig : Int = cast (255.99 * g)
      let ib : Int = cast (255.99 * b)

      _ <- fPutStrLn stdout $ (show ir) ++ " " ++ (show ig) ++ " " ++ (show ib)

      renderCells i j

    renderRows : (j : Nat) -> IO (Either FileError ())
    renderRows Z = pure (Right ())
    renderRows (S j) = do
      _ <- trace ("Scanlines remaining: " ++ (show (j + 1))) $ pure ()
      _ <- renderCells imageWidth j
      renderRows j


module Main

import System

readNum : IO (Maybe Nat)
readNum = do
  input <- getLine
  let output =  if all isDigit (unpack input)
    then (Just (cast input))
    else Nothing
  pure output

takeGuess : (target : Nat) -> IO (Maybe Ordering)
takeGuess target = do
  Just g <- readNum
    | Nothing => pure Nothing
  pure (Just (compare g target))

guess : (target : Nat) -> (guesses : Nat) -> IO ()
guess target guesses = do
  putStr ((show guesses) ++ ": Guess? ")
  result <- takeGuess target
  case result of
    Just EQ => putStrLn "Got it!"
    Nothing => putStrLn "Invalid Number" >>= \_ => guess target (S guesses)
    Just LT => putStrLn "Too Low" >>= \_ => guess target (S guesses)
    Just GT => putStrLn "Too High" >>= \_ => guess target (S guesses)

main : IO ()
main = do
  t <- time
  let target = mod t 100
  guess (cast target) Z


1 f : (1 _ : Nat) -> Nat
f x = S x -- + 1 -- !! Wow, `+` is not linear! I can't use it here!

g : Nat -> Nat
g x = f x

h : Nat -> Nat
h x = let fx = f x in ?foo -- fx is linear because the whole function is!

--- Passing the functions ---

-- Like `f` but without `1` quantity on the whole function.
f' : (1 _ : Nat) -> Nat
f' x = S x

fi : (1 f : (1 _ : Nat) -> Nat) -> Nat -> Nat
fi f x = let fx = f x in fx -- ?foo_fi -- fx is linear like above

fi_f : Nat -> Nat
fi_f = fi f

fi_f' : Nat -> Nat
fi_f' = fi f'

fj : (f : (1 _ : Nat) -> Nat) -> Nat -> Nat
fj f x = let fx = f x in ?foo_fj -- fx is NOT linear

fj_f' : Nat -> Nat
fj_f' = fj f'

useTwice : Nat -> Nat -> Nat
useTwice x y = let fx = f x
                   fy = f y
                   xx = f
               in ?foo_twice

fj_f : Nat -> Nat
fj_f = fj ?foo_f -- if we try `f` here, we get "trying to use f in non-linear context"

------

local : Nat -> Nat
local x = let 1 foj : (1 _ : Nat) -> Nat
              foj x = S x in
          let 1 foy : (1 _ : Nat) -> Nat
              foy = foj in
          --let 1 fox = foj in
          x
  where
    1 foo : (1 _ : Nat) -> Nat
    foo x = S x


-- This test ensures that implicits bound on the RHS of a
-- record update field are correctly bound by the compiler.

record Rec where
    n : Nat

data T : Rec -> Type where
    C : T ({ n := Z } r)

data U : Rec -> Type where
    D : U ({ n $= S } r)


> module Ordering.Properties

> %default total
> %access public export
> %auto_implicits on

> |||
> Uninhabited (LT = EQ) where
>   uninhabited Refl impossible

> |||
> Uninhabited (Prelude.Interfaces.LT = GT) where
>   uninhabited Refl impossible

> |||
> Uninhabited (EQ = GT) where
>   uninhabited Refl impossible

> |||
> Uninhabited (EQ = LT) where
>   uninhabited Refl impossible

> |||
> Uninhabited (Prelude.Interfaces.GT = LT) where
>   uninhabited Refl impossible

> |||
> Uninhabited (GT = EQ) where
>   uninhabited Refl impossible


module Control.Comonad.Store.Store

import Control.Comonad
import Control.Comonad.Trans
import Control.Monad.Identity

%default total

public export
record StoreT (s : Type) (w : Type -> Type) (a : Type) where
  constructor MkStoreT
  run : w (s -> a)
  val : s

public export
Store : (s : Type) -> (a : Type) -> Type
Store s = StoreT s Identity

||| Create a Store using an accessor function and a stored value
public export
store : (s -> a) -> s -> Store s a
store f s = MkStoreT (Id f) s

public export
runStore : Store s a -> (s -> a, s)
runStore (MkStoreT (Id f) s) = (f, s)

public export
runStoreT : StoreT s w a -> (w (s -> a), s)
runStoreT (MkStoreT wf s) = (wf, s)

--------------------------------------------------------------------------------
--          Interface Implementations
--------------------------------------------------------------------------------

public export
Functor w => Functor (StoreT s w) where
  map f = record { run $= map (f .) }

appEnv : (s -> a -> b) -> (s -> a) -> s -> b
appEnv ff fa s = ff s (fa s)

public export
(Monoid s, Applicative w) => Applicative (StoreT s w) where
  pure a = MkStoreT (pure $ const a) neutral
  MkStoreT f m <*> MkStoreT a n = MkStoreT [| appEnv f a |]  (m <+> n)

public export
Comonad w => Comonad (StoreT s w) where
  extract (MkStoreT wf s)   = extract wf s
  duplicate (MkStoreT wf s) = MkStoreT (extend MkStoreT wf) s
  extend f (MkStoreT wf s)  =
    MkStoreT (extend (\wf',s' => f (MkStoreT wf' s')) wf) s

public export
ComonadTrans (StoreT s) where
  lower (MkStoreT f s) = map ($ s) f

public export
(ComonadApply w, Semigroup s) => ComonadApply (StoreT s w) where
  MkStoreT f m <@> MkStoreT a n = MkStoreT (map appEnv f <@> a) (m <+> n)


||| Spec: https://webassembly.github.io/spec/core/syntax/modules.html#element-segments
module WebAssembly.Structure.Modules.ElementSegments

import WebAssembly.Structure.Types
import WebAssembly.Structure.Instructions
import WebAssembly.Structure.Modules.Indices

import Decidable.Equality

-- Definition

public export
record Elem where
  constructor MkElem
  table   : TableIdx
  offset : Expr
  init   : List FuncIdx

-- Equality

total public export
lemma_elem__table_injective : ((t1 = t2) -> Void) -> (MkElem t1 o1 i1 = MkElem t2 o2 i2) -> Void
lemma_elem__table_injective t1_not_t2 Refl = t1_not_t2 Refl

total public export
lemma_elem__offset_injective : ((o1 = o2) -> Void) -> (MkElem t1 o1 i1 = MkElem t2 o2 i2) -> Void
lemma_elem__offset_injective o1_not_o2 Refl = o1_not_o2 Refl

total public export
lemma_elem__init_injective : ((i1 = i2) -> Void) -> (MkElem t1 o1 i1 = MkElem t2 o2 i2) -> Void
lemma_elem__init_injective i1_not_i2 Refl = i1_not_i2 Refl

-- Dedidable Equality

public export
implementation DecEq Elem where
  decEq (MkElem t1 o1 i1) (MkElem t2 o2 i2) = case decEq t1 t2 of
    No t1_not_t2 => No $ lemma_elem__table_injective t1_not_t2
    Yes Refl     => case decEq o1 o2 of
      No o1_not_o2 => No $ lemma_elem__offset_injective o1_not_o2
      Yes Refl     => case decEq i1 i2 of
        No i1_not_i2 => No $ lemma_elem__init_injective i1_not_i2
        Yes Refl     => Yes Refl


module TestIntegers

import Data.Bits
import Data.List.Quantifiers

put : Show a => a -> IO ()
put = putStrLn . show

castAllTo : (to : Type)
         -> {0 types : List Type}
         -> All (flip Cast to) types => HList types -> List to
castAllTo to = forget . imapProperty (flip Cast to) (cast {to})

interface Num a => Bits a => SomeBits a where
    one : Index {a}

SomeBits Bits8 where
    one = fromNat 1

SomeBits Bits16 where
    one = fromNat 1

SomeBits Bits32 where
    one = fromNat 1

SomeBits Bits64 where
    one = fromNat 1

SomeBits Int8 where
    one = fromNat 1

SomeBits Int16 where
    one = fromNat 1

SomeBits Int32 where
    one = fromNat 1

SomeBits Int64 where
    one = fromNat 1

SomeBits Int where
    one = fromNat 1

SomeBits Integer where
    one = 1

interface Num a => Ord a => NumOrd a where

Num a => Ord a => NumOrd a where

main : IO ()
main = do
    let ints = the (HList _) [
        the Bits8 0, -- Bits8 min
        the Bits8 50,
        the Bits8 255, -- Bits8 max
        the Bits16 0, -- Bits16 min
        the Bits16 10000,
        the Bits16 65535, -- Bits16 max
        the Bits32 0, -- Bits32 min
        the Bits32 1000000000,
        the Bits32 4294967295, -- Bits32 max
        the Bits64 0, -- Bits64 min
        the Bits64 5000000000000000000,
        the Bits64 18446744073709551615, -- Bits64 max
        the Int8 $ -128, -- Int8 min
        the Int8 50,
        the Int8 127, -- Int8 max
        the Int16 $ -32768, -- Int16 min
        the Int16 10000,
        the Int16 32767, -- Int16 max
        the Int32 $ -2147483648, -- Int32 min
        the Int32 500000000,
        the Int32 2147483647, -- Int32 max
        the Int64 $ -9223372036854775808, -- Int64 min
        the Int64 1000000000000000000,
        the Int64 9223372036854775807, -- Int64 max
        the Int $ -9223372036854775808, -- Int min
        the Int 1000000000000000000,
        the Int 9223372036854775807, -- Int max
        the Integer $ -9223372036854775809, -- Int min - 1
        the Integer 0,
        the Integer 9223372036854775808 -- Int max + 1
    ]

    putStrLn "Cast to String:"
    put ints

    putStrLn "Cast to Bits8:"
    put $ castAllTo Bits8 ints

    putStrLn "Cast to Bits16:"
    put $ castAllTo Bits16 ints

    putStrLn "Cast to Bits32:"
    put $ castAllTo Bits32 ints

    putStrLn "Cast to Bits64:"
    put $ castAllTo Bits64 ints

    putStrLn "Cast to Int:"
    put $ castAllTo Int ints

    putStrLn "Cast to Integer:"
    put $ castAllTo Integer ints

    putStrLn "Add:"
    put $ imapProperty Num (+ 1) ints

    putStrLn "Subtract:"
    put $ imapProperty Neg (flip (-) 1) ints

    putStrLn "Negate:"
    put $ imapProperty Neg negate ints

    putStrLn "Multiply:"
    put $ imapProperty Num (* 2) ints

--    putStrLn "Divide:"
--    put $ imapProperty Integral (`div` 3) ints
--    put $ imapProperty Integral (`div` -3) ints
--
--    putStrLn "Mod:"
--    put $ imapProperty Integral (`mod` 17) ints
--    put $ imapProperty Integral (`mod` -17) ints
--
--    putStrLn "Division Euclidean:"
--    put $ imapProperty Integral (\x => (x `div` 19) * 19 + (x `mod` 19)) ints
--    put $ imapProperty Integral (\x => (x `div` -19) * -19 + (x `mod` -19)) ints

    putStrLn "Shift:"
    put $ imapProperty SomeBits (`shiftL` one) ints
    put $ imapProperty SomeBits (`shiftR` one) ints

    putStrLn "Bit Ops:"
    put $ imapProperty SomeBits (.&. 0xAA) ints
    put $ imapProperty SomeBits (.|. 0xAA) ints
    put $ imapProperty SomeBits (`xor` 0xAA) ints

    putStrLn "Comparisons:"
    put $ imapProperty NumOrd (< 0) ints
    put $ imapProperty NumOrd (< 1) ints
    put $ imapProperty NumOrd (> 0) ints
    put $ imapProperty NumOrd (> 1) ints
    put $ imapProperty NumOrd (== 0) ints
    put $ imapProperty NumOrd (<= 0) ints
    put $ imapProperty NumOrd (<= 1) ints
    put $ imapProperty NumOrd (>= 0) ints
    put $ imapProperty NumOrd (>= 1) ints


module Cordial.Model.Common.Label

%default total
%access public export

data LabelKind = ANY | NAMED | INDEXED

||| Named labels for signals.
|||
||| @kind   The kind of label.
||| @ty The type associated with each label.
data Label : (kind : LabelKind) -> (ty : Type) -> Type where
  ||| Represents 'Any' label.
  A : Label ANY ty
  ||| Represents a 'Named' label.
  N : ty -> Label NAMED ty
  ||| Represents an indexed 'Named' label.
  I : ty -> Nat -> Label INDEXED ty

Show rTy => Show (Label kind rTy) where
  show A       = "any"
  show (N x)   = show x
  show (I x k) = show x <+> "_" <+> show k


module GenericZipWith

import Data.Vect

Id : Type -> Type
Id x = x

Func : (args : Vect n Type) -> (ret : Type) -> (Type -> Type) -> Type
Func [] r f = f r
Func (x :: xs) r f = (a : f x) -> Func xs r f

gApp : Applicative f => f (Func v r Id) -> Func v r f
gApp {v = []} fs = fs
gApp {v = (x :: xs)} fs = \vs => gApp (fs <*> vs)

gZipWith : Applicative f => Func v r Id -> Func v r f
gZipWith {f} f' = gApp {f = f} (pure f')

zipWith' : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c
zipWith' f = gZipWith {v = [a, b]} f

zipWith3' : (a -> b -> c -> d) -> Vect n a -> Vect n b -> Vect n c -> Vect n d
zipWith3' f = gZipWith {v = [a, b, c]} f

map' : (a -> b) -> Vect n a -> Vect n b
map' f = gZipWith {v = [a]} f

repeat' : b -> Vect n b
repeat' b = gZipWith {v = []} b

example : Vect 2 (Int, Bool)
example = zipWith' (\i, b => (i, b)) [1, 2] [True, False]


ones : Stream Integer
ones = num :: ones
  where
    num : Integer -- gratuitous where for a regression test!
    num = 1

readNat : IO Nat
readNat = pure $ -- sprinkle some IO to prevent inlining
  case !getLine of
    "42" => Z
    _ => S (S (S (S Z)))

main : IO ()
main = do
  n <- readNat
  print (take n ones)


module IntegerArith

import IntegerOrdering
import IntegerGroupTheory

{-
Strategy (<) type:

To handle case a (-a)
autogen a type which is either a<b or a>b and a proof of it.
match on the with of the generating function, so that you can have distinct cases of the inequality treated as creating different assumptions about the values a and b.
use this pattern matching structure in the definition of gcdBigInt itself.
Reflection shouldn't be needed, then, except maybe for gcdBigInt a 0.

We can implement this inequality type (which mirrors LTE for Nats) using recursion, even though we aren't given a fixed enumeration of Integer, because we have decEq.

	decEq 5 3 = No ( _ 5 3 ) : Dec (5 = 3)
	decEq 5 5 = Yes Refl : (5=5)

Although actually, a case expression on (decEq a b) may be enough instead of a dependent pattern match, because the case matched on itself has a proof, and one might be able to reuse that...

=======

Strategy rewrite case argument:

If the function you're trying to prove matches an equality has a case expression or equivalent in it, we can show that the function can be computed by assuming this has a particular value, and thus when we can take the case expression outside the equality and the cases being matched on include a proof of something which determines the value of the case argument, we can apply a function using this proof to obtain a proof that the case argument is the required value.

So if our case argument is (decLT (a*b) 0) then we can get a

	(decLT (a*b) 0 = Yes pr)

from the (Yes pr : DecLT (a*b) 0) that one is pattern matching on when trying to generate the equality of gcdBigInt with its definition, by a function which manually constructs the proof from (pr) if Refl won't be recognized.

Once that (decLT (a*b) 0 = Yes pr) is used to rewrite the case argument of the equality-with-definition generator from (decLT (a*b) 0) to one of the cases (Yes _) of the case expressions in the gcdBigInt definition, we should be able to use compute to collapse the case expression and obtain the desired equality.

=======

Strategy recursion:

gcdBigInt can probably be reduced to a single case expression step followed by the usual gcd on nonnegative numbers, which by not having a case expression can be proved total just like gcd can. So gcdBigInt could be proved total simply by factorization.

-}

{-
-- IntegerArith.gcdBigInt is possibly not total due to recursive path IntegerArith.gcdBigInt
-- %reflection
total
gcdBigInt : Integer -> Integer -> Integer
gcdBigInt a 0 = a
gcdBigInt a b = if a*b<0 then gcdBigInt (abs a) (abs b) else assert_total (gcdBigInt b (modBigInt a b))
-}

{-
-- IntegerArith.gcdBigInt is possibly not total due to: IntegerArith.case block in gcdBigInt

total
gcdBigInt : Integer -> Integer -> Integer
gcdBigInt a 0 = a
gcdBigInt a b = case ( decLT (a*b) 0 ) of
		Yes pr => gcdBigInt (abs a) (abs b)
		otherwise => gcdBigInt b (modBigInt a b)
-}

{-
-- IntegerArith.gcdBigInt is possibly not total due to: with block in IntegerArith.gcdBigInt

total
gcdBigInt : Integer -> Integer -> Integer
gcdBigInt a 0 = a
gcdBigInt a b with ( decLT (a*b) 0 )
	| Yes pr = gcdBigInt (abs a) (abs b)
	| otherwise = gcdBigInt b (modBigInt a b)
-}

{-
%reflection
total
gcdType : Integer -> Integer -> Type
gcdType a 0 = ( gcdBigInt a 0 = a )
gcdType a b with (decEq a (-b))
	| Yes pr =
	| No pr =
-}
{-
gcdType a b = ( gcdBigInt a b = if a*b<0 then gcdBigInt (abs a) (abs b) else assert_total (gcdBigInt b (modBigInt a b)) )
-}
{-
gcdType a b = if a*b<0 then ( gcdBigInt a b = gcdBigInt (abs a) (abs b) ) else ( gcdBigInt a b = gcdBigInt b (modBigInt a b) )
-}

{-
gcddefBigInt : (a : Integer) -> (b : Integer) -> gcdType a b
gcddefBigInt a 0 = Refl
gcddefBigInt a b = if a*b<0 then the ( gcdBigInt a b = gcdBigInt (abs a) (abs b) ) gcddefBigIntZeroPr else gcddefBigIntPr -- believe_me "by definition"
	where
		gcddefBigIntZeroPr = ?gcddefBigIntZeroPr'
		gcddefBigIntPr = ?gcddefBigIntPr'
-}

total
modBigInt_total : Integer -> Integer -> Integer
modBigInt_total a 0 = a
-- This is wrong too, in fact (div 5 (-2) = -3), so not even close.
-- I suspect we must define remainders as coset representatives or by long division.
modBigInt_total a b = a - div a b

{-
Would have said

	modBigInt_total a b = prim__sremBigInt a b

but need to be able to prove modEqBigInt.
If we can't prove this, we might as well switch to a definition of div in.
-}
modEqRem : (a : Integer) -> (b : Integer) -> (nzpr : Not (b=0)) -> (a - div a b = prim__sremBigInt a b)

{-
modeqBigInt : (a : Integer) -> (b : Integer) -> (nzpr : Not (b=0))
	-> mod a b + (div (a - mod a b) b)*b = a
-}

modeqBigInt : (a : Integer) -> (b : Integer) -> (nzpr : Not (b=0))
	-> modBigInt_total a b + (div (a - modBigInt_total a b) b)*b = a
modeqBigInt a b pr = ?modeqBigIntHole


module Data.LeftPad

import Data.List
import Data.List.Predicates.Interleaving

%default total
%access public export

data Padding : (s : List Char) -> (target : Nat) -> Type where
  Pad : (pad : Nat) -> Padding s (length s + pad)
  Nop : Padding (ys ++ x :: xs) (length ys)

padding : (s : List Char) -> (target : Nat) -> Padding s target
padding       []     t  = Pad t
padding (x :: xs)    Z  = Nop {ys = []}
padding (x :: xs) (S t) with (padding xs t)
  padding (x :: xs) (S (plus (length xs) p))   | Pad p = Pad p
  padding (y :: ys ++ z :: zs) (S (length ys)) | Nop   = Nop {ys=y::ys}

pad : (s : List Char) -> (c : Char) -> (target : Nat) -> List Char
pad s c target with (padding s target)
  pad s c (length s + pad)          | Pad pad  = replicate pad c ++ s
  pad (ys ++ x :: xs) c (length ys) | Nop {ys} = ys ++ x :: xs

namespace MorePad
  Pad : (s : List Char) -> (c : Char) -> (target : Nat) -> Type
  Pad s c target with (padding s target)
    Pad s c ((length s) + pad) | (Pad pad) = let ps = replicate pad c in Interleaving ps s (ps ++ s)

    Pad (ys ++ (x :: xs)) c (length ys) | Nop = Interleaving Nil (ys ++ (x :: xs)) (ys ++ (x :: xs))

  noPad : (s : List Char) -> Interleaving Nil s s
  noPad [] = Empty
  noPad (x :: xs) = RightAdd x (noPad xs)

  addPadd : (pad : List Char) -> (s : List Char) -> Interleaving pad s (pad ++ s)
  addPadd [] s = noPad s
  addPadd (x :: xs) s = LeftAdd x (addPadd xs s)

  pad : (s : List Char) -> (c : Char) -> (target : Nat) -> Pad s c target
  pad s c target with (padding s target)
    pad s c ((length s) + pad) | (Pad pad) = let ps = replicate pad c in addPadd ps s
    pad (ys ++ (x :: xs)) c (length ys) | Nop = noPad (ys ++ (x::xs))


module Data.Vect.Extras

import Data.Vect
import Data.Vect.Views

%default total
%access export

foldrM :  Monad m => (func : elem -> acc -> m acc) -> (init : acc) -> (input : Vect n elem) -> m acc
foldrM func init input with (snocVect input)
    foldrM _ init [] | Empty = pure init
    foldrM func init (xs ++ [x]) | Snoc rec = foldrM func !(func x init) xs | rec

mapM : Monad m => (func : elem -> m r) -> (input : Vect n elem) -> m (Vect n r)
mapM = helper []
where helper :  Monad m => Vect n r -> (elem -> m r) ->  Vect n' elem -> m (Vect (n + n') r)
      helper {n} acc func [] =
          rewrite plusZeroRightNeutral n in
          pure acc
      helper {n} {n' = S k} acc func (x :: xs) =
          rewrite sym $ plusSuccRightSucc n k in
          do helper (!(func x) :: acc) func xs


module Control.Monad.Indexed

import Control.Functor.Indexed
import Control.Applicative.Indexed

infixl 1 >>>=, =<<<, >>>, >>=>, <=<<

public export
interface IndexedApplicative z m => IndexedMonad z m | m where
  total
  bind : {0 i,j,k : z} -> m a i j -> (a -> m b j k) -> m b i k

  total
  join : {0 i,j,k : z} -> m (m a j k) i j -> m a i k

  -- default implementations
  bind x f = join (map f x)
  join x = bind x id

public export
(>>>=) : IndexedMonad z m => m a i j -> (a -> m b j k) -> m b i k
(>>>=) = bind

||| Flipped version of `>>>=`
public export
(=<<<) : IndexedMonad z m => (a -> m b j k) -> m a i j -> m b i k
(=<<<) = flip (>>>=)

||| Sequence effects taking the value of the second.
public export
(>>>) : IndexedMonad z m => m () i j -> Lazy (m b j k) -> m b i k
(>>>) x y = x >>>= \_ => y

||| Left-to-right Kleisli composition of indexed monads.
public export
(>>=>) : IndexedMonad z m => (a -> m b i j) -> (b -> m c j k) -> (a -> m c i k)
(>>=>) f g x = f x >>>= g

||| Right-to-left Kleisli composition of indexed monads, flipped version of `>=>`.
public export
(<=<<) : IndexedMonad z m => (b -> m c j k) -> (a -> m b i j) -> (a -> m c i k)
(<=<<) = flip (>>=>)


||| Using single machine-word as Bitarray.
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Data.Container.IntSet

import Data.Container.Interfaces

import Data.Bits
import Data.Maybe               -- fromMaybe
import Data.So
import Data.SortedMap as M      -- mergeWith, empty
import Decidable.Equality

%default total

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

-- 0 decideTiny : (n:Nat) -> Dec ((n <= 32) = True)
decideTiny : (n:Nat) -> Dec ((n <= 32) = True)
decideTiny n = decEq (n <= 32) True

export IntSet : (N:Nat) -> Type
IntSet n with (decideTiny n)
  IntSet _ | Yes _ = Bits32
  IntSet _ | No _  = M.SortedMap Integer Bits32

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

export
(n:Nat) => Semigroup (IntSet n) where
  x <+> y with (decideTiny n)
    x <+> y | Yes _ = prim__or_Bits32 x y
    x <+> y | No _  = M.mergeWith prim__or_Bits32 x y

export
(n:Nat) => Semigroup (IntSet n) => Monoid (IntSet n) where
  neutral with (decideTiny n)
    neutral | Yes _ = 0
    neutral | No _  = M.empty

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

keyix : Integer -> (Integer, Bits32)
keyix k =
  let i = if k >= 0 then (k `div` 32) else (negate $ (k - 1) `div` 32)
      b = fromInteger $ abs $ k `mod` 32
   in (i, b)

export
{n:Nat} -> Container (IntSet n) where
  KeyTy = Integer
  null xs with (decideTiny n)
    null xs | Yes _ = xs == 0
    null xs | No _  = null xs
  count xs with (decideTiny n)
    count xs | Yes _ = popCount xs
    count xs | No _  = foldl (\acc, b => acc + popCount b) 0 xs
  contains k xs with (decideTiny n)
    contains k xs | Yes _ =
      if k >= 0 && k < 32
        then 0 /= (prim__and_Bits32 xs $ prim__shl_Bits32 1 $ fromInteger k)
        else False
    contains k xs | No  _ =
      let (i, b) = keyix k
       in maybe False (\ys => 0 /= (prim__and_Bits32 ys $ prim__shl_Bits32 1 b))
                (M.lookup i xs)
  delete k xs with (decideTiny n)
    delete k xs | Yes _ =
      if k >= 0 && k < 32
         then prim__and_Bits32 xs $ prim__xor_Bits32 0xffffffff $ prim__shl_Bits32 1 $ fromInteger k
         else xs
    delete k xs | No _  =
      let (i, b) = keyix k
       in maybe xs (\ys => M.insert i (prim__and_Bits32 ys $ prim__xor_Bits32 0xffffffff $ prim__shl_Bits32 1 b) xs)
                (M.lookup i xs)

export
(n:Nat) => (Container (IntSet n)) => Set (IntSet n) where
  KeyTy = Integer
  insert k xs with (decideTiny n)
    insert k xs | Yes _ =
      if k >= 0 && k < 32
         then prim__or_Bits32 xs $ prim__shl_Bits32 1 $ fromInteger k
         else xs
    insert k xs | No  _ =
      let (i, b) = keyix k
       in M.insert i
                   (prim__or_Bits32 (fromMaybe 0 (M.lookup i xs)) $ prim__shl_Bits32 1 b)
                   xs

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