-- exercises in "Type-Driven Development with Idris"
-- chapter 6

-- check that all functions are total
%default total

data Format = Number Format
            | Doubble Format
            | Str Format
            | Chhar Format
            | Lit String Format
            | End
%name Format fmt, fmt1, fmt2, fmt3

PrintfType : Format -> Type
PrintfType (Number fmt) = (i : Int) -> PrintfType fmt
PrintfType (Doubble fmt) = (d : Double) -> PrintfType fmt
PrintfType (Str fmt) = (str : String) -> PrintfType fmt
PrintfType (Chhar fmt) = (car : Char) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType End = String

printFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printFmt (Number fmt) acc = \i => printFmt fmt (acc ++ show i)
printFmt (Doubble fmt) acc = \d => printFmt fmt (acc ++ show d)
printFmt (Str fmt) acc = \str => printFmt fmt (acc ++ str)
printFmt (Chhar fmt) acc = \char => printFmt fmt (acc ++ show char)
printFmt (Lit str fmt) acc = printFmt fmt (acc ++ str)
printFmt End acc = acc

toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 'f' :: chars) = Doubble (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: 'c' :: chars) = Chhar (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
                          Lit str chars' => Lit (strCons c str) chars'
                          fmt => Lit (strCons c "") fmt

printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printFmt _ ""
-- > :t printf "%s = %d"
-- printf "%s = %d" : String -> Int -> String
-- > :t printf "%c %f"
-- printf "%c %f" : Char -> Double -> String
-- > printf "%c %f" 'X' 24
-- "'X' 24.0" : String


module ProofColDivSeqPostulate

import ProofColDivSeqBase

%default total
-- %language ElabReflection
%access export

%hide Language.Reflection.P

--            from ProofColDivSeqBase
-- ########################################
-- 無限降下法（の変形） Isabelleで証明した
postulate infiniteDescent :
  ((n:Nat) -> P (S n) 2 -> (m ** (LTE (S m) (S n), P m 2)))
    -> All Limited $ allDivSeq Z 2
      -> All Limited $ allDivSeq (n+n+n) 2

-- BaseLog0.txtより、保証される
postulate base0 : All Limited $ allDivSeq Z 2
-- ########################################

--            from ProofColDivSeqLvDown
-- ########################################
any2Sub : {pp : a -> Type} -> (x : a) -> (xs, ys : List a)
  -> Either (Any pp xs) (Any pp ys) -> Either (Any pp (x :: xs)) (Any pp ys)
any2Sub x []       ys (Left anL)  = absurd anL
any2Sub x (x2::xs) ys (Left anL)  = Left (There anL)
any2Sub x xs       ys (Right anR) = Right anR

-- これが肝
any2 : {pp : a -> Type} -> (xs, ys : List a)
  -> Any pp (xs ++ ys) -> Either (Any pp xs) (Any pp ys)
any2 []      ys an         = Right an
any2 (x::xs) ys (Here he)  = Left (Here he)
any2 (x::xs) ys (There th) =
  let foo = any2 xs ys th in any2Sub x xs ys foo

any3 : {pp : a -> Type} -> (xs1, xs2, xs3 : List a)
  -> Either (Any pp xs1) (Any pp (xs2++xs3))
    -> Either (Any pp xs1) (Either (Any pp xs2) (Any pp xs3))
any3 xs1 xs2 xs3 (Left prfL)  = Left prfL
any3 xs1 xs2 xs3 (Right prfR) = Right (any2 xs2 xs3 prfR)

any4 : {pp : a -> Type} -> (xs1, xs2, xs3, xs4 : List a)
  -> Either (Any pp xs1) (Either (Any pp xs2) (Any pp (xs3++xs4)))
    -> Either (Any pp xs1) (Either (Any pp xs2) (Either (Any pp xs3) (Any pp xs4)))
any4 xs1 xs2 xs3 xs4 (Left prfL)           = Left prfL
any4 xs1 xs2 xs3 xs4 (Right (Left prfRL))  = Right (Left prfRL)
any4 xs1 xs2 xs3 xs4 (Right (Right prfRR)) = Right (Right (any2 xs3 xs4 prfRR))

any5 : {pp : a -> Type} -> (xs1, xs2, xs3, xs4, xs5 : List a)
  -> Either (Any pp xs1) (Either (Any pp xs2) (Either (Any pp xs3) (Any pp (xs4++xs5))))
    -> Either (Any pp xs1) (Either (Any pp xs2) (Either (Any pp xs3) (Either (Any pp xs4) (Any pp xs5))))
any5 xs1 xs2 xs3 xs4 xs5 (Left prfL)                    = Left prfL
any5 xs1 xs2 xs3 xs4 xs5 (Right (Left prfRL))           = Right (Left prfRL)
any5 xs1 xs2 xs3 xs4 xs5 (Right (Right (Left prfRRL)))  = Right (Right (Left prfRRL))
any5 xs1 xs2 xs3 xs4 xs5 (Right (Right (Right prfRRR))) = Right (Right (Right (any2 xs4 xs5 prfRRR)))

any6 : {pp : a -> Type} -> (xs1, xs2, xs3, xs4, xs5, xs6 : List a)
  -> Either (Any pp xs1) (Either (Any pp xs2) (Either (Any pp xs3) (Either (Any pp xs4) (Any pp (xs5++xs6)))))
    -> Either (Any pp xs1) (Either (Any pp xs2) (Either (Any pp xs3) (Either (Any pp xs4) (Either (Any pp xs5) (Any pp xs6)))))
any6 xs1 xs2 xs3 xs4 xs5 xs6 (Left prfL)                             = Left prfL
any6 xs1 xs2 xs3 xs4 xs5 xs6 (Right (Left prfRL))                    = Right (Left prfRL)
any6 xs1 xs2 xs3 xs4 xs5 xs6 (Right (Right (Left prfRRL)))           = Right (Right (Left prfRRL))
any6 xs1 xs2 xs3 xs4 xs5 xs6 (Right (Right (Right (Left prfRRRL))))  = Right (Right (Right (Left prfRRRL)))
any6 xs1 xs2 xs3 xs4 xs5 xs6 (Right (Right (Right (Right prfRRRR)))) = Right (Right (Right (Right (any2 xs5 xs6 prfRRRR))))

any7 : {pp : a -> Type} -> (xs1, xs2, xs3, xs4, xs5, xs6, xs7 : List a)
  -> Either (Any pp xs1) (Either (Any pp xs2) (Either (Any pp xs3) (Either (Any pp xs4) (Either (Any pp xs5) (Any pp (xs6++xs7))))))
    -> Either (Any pp xs1) (Either (Any pp xs2) (Either (Any pp xs3) (Either (Any pp xs4) (Either (Any pp xs5) (Either (Any pp xs6) (Any pp xs7))))))
any7 xs1 xs2 xs3 xs4 xs5 xs6 xs7 (Left prfL)                                      = Left prfL
any7 xs1 xs2 xs3 xs4 xs5 xs6 xs7 (Right (Left prfRL))                             = Right (Left prfRL)
any7 xs1 xs2 xs3 xs4 xs5 xs6 xs7 (Right (Right (Left prfRRL)))                    = Right (Right (Left prfRRL))
any7 xs1 xs2 xs3 xs4 xs5 xs6 xs7 (Right (Right (Right (Left prfRRRL))))           = Right (Right (Right (Left prfRRRL)))
any7 xs1 xs2 xs3 xs4 xs5 xs6 xs7 (Right (Right (Right (Right (Left prfRRRRL)))))  = Right (Right (Right (Right (Left prfRRRRL))))
any7 xs1 xs2 xs3 xs4 xs5 xs6 xs7 (Right (Right (Right (Right (Right prfRRRRR))))) = Right (Right (Right (Right (Right (any2 xs6 xs7 prfRRRRR)))))

any8 : {pp : a -> Type} -> (xs1, xs2, xs3, xs4, xs5, xs6, xs7, xs8 : List a)
  -> Either (Any pp xs1) (Either (Any pp xs2) (Either (Any pp xs3) (Either (Any pp xs4) (Either (Any pp xs5) (Either (Any pp xs6) (Any pp (xs7++xs8)))))))
    -> Either (Any pp xs1) (Either (Any pp xs2) (Either (Any pp xs3) (Either (Any pp xs4) (Either (Any pp xs5) (Either (Any pp xs6) (Either (Any pp xs7) (Any pp xs8)))))))
any8 xs1 xs2 xs3 xs4 xs5 xs6 xs7 xs8 (Left prfL)                                               = Left prfL
any8 xs1 xs2 xs3 xs4 xs5 xs6 xs7 xs8 (Right (Left prfRL))                                      = Right (Left prfRL)
any8 xs1 xs2 xs3 xs4 xs5 xs6 xs7 xs8 (Right (Right (Left prfRRL)))                             = Right (Right (Left prfRRL))
any8 xs1 xs2 xs3 xs4 xs5 xs6 xs7 xs8 (Right (Right (Right (Left prfRRRL))))                    = Right (Right (Right (Left prfRRRL)))
any8 xs1 xs2 xs3 xs4 xs5 xs6 xs7 xs8 (Right (Right (Right (Right (Left prfRRRRL)))))           = Right (Right (Right (Right (Left prfRRRRL))))
any8 xs1 xs2 xs3 xs4 xs5 xs6 xs7 xs8 (Right (Right (Right (Right (Right (Left prfRRRRRL))))))  = Right (Right (Right (Right (Right (Left prfRRRRRL)))))
any8 xs1 xs2 xs3 xs4 xs5 xs6 xs7 xs8 (Right (Right (Right (Right (Right (Right prfRRRRRR)))))) = Right (Right (Right (Right (Right (Right (any2 xs7 xs8 prfRRRRRR))))))

anyFinal : {pp : a -> Type} -> (xs1, xs2, xs3, xs4, xs5, xs6, xs7, xs8 : List a)
  -> Any pp (xs1 ++ xs2 ++ xs3 ++ xs4 ++ xs5 ++ xs6 ++ xs7 ++ xs8)
    -> Either (Any pp xs1) (Either (Any pp xs2) (Either (Any pp xs3) (Either (Any pp xs4) (Either (Any pp xs5) (Either (Any pp xs6) (Either (Any pp xs7) (Any pp xs8)))))))
anyFinal xs1 xs2 xs3 xs4 xs5 xs6 xs7 xs8 prf =
  let prf2 = any2 xs1 (xs2 ++ xs3 ++ xs4 ++ xs5 ++ xs6 ++ xs7 ++ xs8) prf in
  let prf3 = any3 xs1 xs2 (xs3 ++ xs4 ++ xs5 ++ xs6 ++ xs7 ++ xs8) prf2 in
  let prf4 = any4 xs1 xs2 xs3 (xs4 ++ xs5 ++ xs6 ++ xs7 ++ xs8) prf3 in
  let prf5 = any5 xs1 xs2 xs3 xs4 (xs5 ++ xs6 ++ xs7 ++ xs8) prf4 in
  let prf6 = any6 xs1 xs2 xs3 xs4 xs5 (xs6 ++ xs7 ++ xs8) prf5 in
  let prf7 = any7 xs1 xs2 xs3 xs4 xs5 xs6 (xs7 ++ xs8) prf6 in
  let prf8 = any8 xs1 xs2 xs3 xs4 xs5 xs6 xs7 xs8 prf7 in prf8

-- 前方を削っているのは、（有限or無限を判定する）末尾に影響を与えないから
postulate dspCut : Any (Not . Limited) (map ([a,b] `dsp`) xs)
  -> Any (Not . Limited) xs
postulate dsp2Cut : Any (Not . Limited) (map ([a] `dsp2`) xs)
  -> Any (Not . Limited) xs

changeA' : (x, lv:Nat)
  -> Any (Not . Limited)
      (if (modNatNZ (x+7) 4 SIsNotZ) == 0
        then map ([6,-4] `dsp`) $ allDivSeq (divNatNZ ((x+7)*3) 4 SIsNotZ) (S lv)
        else [])
    -> Any (Not . Limited) (allDivSeq (divNatNZ ((x+7)*3) 4 SIsNotZ) (S lv))
changeA' x lv prf with ((modNatNZ (x+7) 4 SIsNotZ) == 0) proof p
  changeA' x lv prf | False = absurd prf
  changeA' x lv prf | True  = dspCut prf
changeA : (x, lv:Nat) -> Any (Not . Limited) (allDivSeqA x (S lv))
  -> Any (Not . Limited) (allDivSeq (divNatNZ ((x+7)*3) 4 SIsNotZ) (S lv))
changeA x lv prf = changeA' x lv $ replace (definiA x lv) prf

changeA0' : (x : Nat)
  -> Any (Not . Limited)
      (if (modNatNZ (x+7) 4 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+7) 4 SIsNotZ) 2 SIsNotZ) == 1
        then [[6,-4] `dsp` (Just (divSeq (divNatNZ ((x+7)*3) 4 SIsNotZ)))]
        else [])
    -> Any (Not . Limited) [Just (divSeq (divNatNZ ((x+7)*3) 4 SIsNotZ))]
changeA0' x prf with ((modNatNZ (x+7) 4 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+7) 4 SIsNotZ) 2 SIsNotZ) == 1) proof p
  changeA0' x prf | False = absurd prf
  changeA0' x prf | True  = dspCut prf
changeA0 : (x:Nat) -> Any (Not . Limited) (allDivSeqA x 0)
  -> Any (Not . Limited) [Just (divSeq (divNatNZ ((x+7)*3) 4 SIsNotZ))]
changeA0 x prf = changeA0' x $ replace (definiA0 x) prf

changeB : (x, lv:Nat) -> Any (Not . Limited) (allDivSeqB x (S lv))
  -> Any (Not . Limited) (allDivSeq (x*6+3) (S lv))
changeB x lv prf = dspCut $ replace (definiB x lv) prf

changeB0' : (x : Nat)
  -> Any (Not . Limited)
      (if (modNatNZ (x*6+3) 2 SIsNotZ) == 1
        then [[1,-2] `dsp` (Just (divSeq (x*6+3)))]
        else [])
    -> Any (Not . Limited) [Just (divSeq (x*6+3))]
changeB0' x prf with ((modNatNZ (x*6+3) 2 SIsNotZ) == 1) proof p
  changeB0' x prf | False = absurd prf
  changeB0' x prf | True  = dspCut prf
changeB0 : (x:Nat) -> Any (Not . Limited) (allDivSeqB x 0)
  -> Any (Not . Limited) [Just (divSeq (x*6+3))]
changeB0 x prf = changeB0' x $ replace (definiB0 x) prf

changeC : (x, lv:Nat) -> Any (Not . Limited) (allDivSeqC x (S lv))
  -> Any (Not . Limited) (allDivSeq (x*3+6) (S lv))
changeC x lv prf = dspCut $ replace (definiC x lv) prf

changeC0' : (x : Nat)
  -> Any (Not . Limited)
      (if (modNatNZ (x*3+6) 2 SIsNotZ) == 1
        then [[4,-4] `dsp` (Just (divSeq (x*3+6)))]
        else [])
    -> Any (Not . Limited) [Just (divSeq (x*3+6))]
changeC0' x prf with ((modNatNZ (x*3+6) 2 SIsNotZ) == 1) proof p
  changeC0' x prf | False = absurd prf
  changeC0' x prf | True  = dspCut prf
changeC0 : (x:Nat) -> Any (Not . Limited) (allDivSeqC x 0)
  -> Any (Not . Limited) [Just (divSeq (x*3+6))]
changeC0 x prf = changeC0' x $ replace (definiC0 x) prf

changeD' : (x, lv:Nat)
  -> Any (Not . Limited)
      (if (modNatNZ (x+1) 2 SIsNotZ) == 0
        then map ([3,-2] `dsp`) $ allDivSeq (divNatNZ ((x+1)*3) 2 SIsNotZ) (S lv)
        else [])
    -> Any (Not . Limited) (allDivSeq (divNatNZ ((x+1)*3) 2 SIsNotZ) (S lv))
changeD' x lv prf with ((modNatNZ (x+1) 2 SIsNotZ) == 0) proof p
  changeD' x lv prf | False = absurd prf
  changeD' x lv prf | True  = dspCut prf
changeD : (x, lv:Nat) -> Any (Not . Limited) (allDivSeqD x (S lv))
  -> Any (Not . Limited) (allDivSeq (divNatNZ ((x+1)*3) 2 SIsNotZ) (S lv))
changeD x lv prf = changeD' x lv $ replace (definiD x lv) prf

changeD0' : (x : Nat)
  -> Any (Not . Limited)
      (if (modNatNZ (x+1) 2 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+1) 2 SIsNotZ) 2 SIsNotZ) == 1
        then [[3,-2] `dsp` (Just (divSeq (divNatNZ ((x+1)*3) 2 SIsNotZ)))]
        else [])
    -> Any (Not . Limited) [Just (divSeq (divNatNZ ((x+1)*3) 2 SIsNotZ))]
changeD0' x prf with ((modNatNZ (x+1) 2 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+1) 2 SIsNotZ) 2 SIsNotZ) == 1) proof p
  changeD0' x prf | False = absurd prf
  changeD0' x prf | True  = dspCut prf
changeD0 : (x:Nat) -> Any (Not . Limited) (allDivSeqD x 0)
  -> Any (Not . Limited) [Just (divSeq (divNatNZ ((x+1)*3) 2 SIsNotZ))]
changeD0 x prf = changeD0' x $ replace (definiD0 x) prf

changeE : (x, lv:Nat) -> Any (Not . Limited) (allDivSeqE x (S lv))
  -> Any (Not . Limited) (allDivSeq (x*12+9) (S lv))
changeE x lv prf = dspCut $ replace (definiE x lv) prf

changeE0' : (x : Nat)
  -> Any (Not . Limited)
      (if (modNatNZ (x*12+9) 2 SIsNotZ) == 1
        then [[2,-4] `dsp` (Just (divSeq (x*12+9)))]
        else [])
    -> Any (Not . Limited) [Just (divSeq (x*12+9))]
changeE0' x prf with ((modNatNZ (x*12+9) 2 SIsNotZ) == 1) proof p
  changeE0' x prf | False = absurd prf
  changeE0' x prf | True  = dspCut prf
changeE0 : (x:Nat) -> Any (Not . Limited) (allDivSeqE x 0)
  -> Any (Not . Limited) [Just (divSeq (x*12+9))]
changeE0 x prf = changeE0' x $ replace (definiE0 x) prf

changeF' : (x, lv:Nat)
  -> Any (Not . Limited)
      (if (modNatNZ (x+3) 8 SIsNotZ) == 0
        then map ([5,-2] `dsp`) $ allDivSeq (divNatNZ ((x+3)*3) 8 SIsNotZ) (S lv)
        else [])
    -> Any (Not . Limited) (allDivSeq (divNatNZ ((x+3)*3) 8 SIsNotZ) (S lv))
changeF' x lv prf with ((modNatNZ (x+3) 8 SIsNotZ) == 0) proof p
  changeF' x lv prf | False = absurd prf
  changeF' x lv prf | True  = dspCut prf
changeF : (x, lv:Nat) -> Any (Not . Limited) (allDivSeqF x (S lv))
  -> Any (Not . Limited) (allDivSeq (divNatNZ ((x+3)*3) 8 SIsNotZ) (S lv))
changeF x lv prf = changeF' x lv $ replace (definiF x lv) prf

changeF0' : (x : Nat)
  -> Any (Not . Limited)
      (if (modNatNZ (x+3) 8 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+3) 8 SIsNotZ) 2 SIsNotZ) == 1
        then [[5,-2] `dsp` (Just (divSeq (divNatNZ ((x+3)*3) 8 SIsNotZ)))]
        else [])
    -> Any (Not . Limited) [Just (divSeq (divNatNZ ((x+3)*3) 8 SIsNotZ))]
changeF0' x prf with ((modNatNZ (x+3) 8 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+3) 8 SIsNotZ) 2 SIsNotZ) == 1) proof p
  changeF0' x prf | False = absurd prf
  changeF0' x prf | True  = dspCut prf
changeF0 : (x:Nat) -> Any (Not . Limited) (allDivSeqF x 0)
  -> Any (Not . Limited) [Just (divSeq (divNatNZ ((x+3)*3) 8 SIsNotZ))]
changeF0 x prf = changeF0' x $ replace (definiF0 x) prf

changeG' : (x, lv:Nat)
  -> Any (Not . Limited)
      (if (modNatNZ (x `minus` 21) 64 SIsNotZ) == 0 && x > 21
        then map ([6] `dsp2`) $ allDivSeq (divNatNZ (x `minus` 21) 64 SIsNotZ) (S lv)
        else [])
    -> Any (Not . Limited) (allDivSeq (divNatNZ (x `minus` 21) 64 SIsNotZ) (S lv))
changeG' x lv prf with ((modNatNZ (x `minus` 21) 64 SIsNotZ) == 0 && x > 21) proof p
  changeG' x lv prf | False = absurd prf
  changeG' x lv prf | True  = dsp2Cut prf
changeG : (x, lv:Nat) -> Any (Not . Limited) (allDivSeqG x (S lv))
  -> Any (Not . Limited) (allDivSeq (divNatNZ (x `minus` 21) 64 SIsNotZ) (S lv))
changeG x lv prf = changeG' x lv $ replace (definiG x lv) prf

changeG0' : (x : Nat)
  -> Any (Not . Limited)
      (if (modNatNZ (x `minus` 21) 64 SIsNotZ) == 0 && x > 21 && (modNatNZ (modNatNZ (x `minus` 21) 64 SIsNotZ) 2 SIsNotZ) == 1
        then [[6] `dsp2` (Just (divSeq (divNatNZ (x `minus` 21) 64 SIsNotZ)))]
        else [])
    -> Any (Not . Limited) [Just (divSeq (divNatNZ (x `minus` 21) 64 SIsNotZ))]
changeG0' x prf with ((modNatNZ (x `minus` 21) 64 SIsNotZ) == 0 && x > 21 && (modNatNZ (modNatNZ (x `minus` 21) 64 SIsNotZ) 2 SIsNotZ) == 1) proof p
  changeG0' x prf | False = absurd prf
  changeG0' x prf | True  = dsp2Cut prf
changeG0 : (x:Nat) -> Any (Not . Limited) (allDivSeqG x 0)
  -> Any (Not . Limited) [Just (divSeq (divNatNZ (x `minus` 21) 64 SIsNotZ))]
changeG0 x prf = changeG0' x $ replace (definiG0 x) prf

postulate defini3 : (x, lv:Nat)
  -> Either (Any (Not . Limited) $ allDivSeq x lv)
    (Either (Any (Not . Limited) $ allDivSeq (divNatNZ ((x+7)*3) 4 SIsNotZ) lv)
      (Either (Any (Not . Limited) $ allDivSeq (x*6+3) lv)
        (Either (Any (Not . Limited) $ allDivSeq (x*3+6) lv)
          (Either (Any (Not . Limited) $ allDivSeq (divNatNZ ((x+1)*3) 2 SIsNotZ) lv)
            (Either (Any (Not . Limited) $ allDivSeq (x*12+9) lv)
              (Either (Any (Not . Limited) $ allDivSeq (divNatNZ ((x+3)*3) 8 SIsNotZ) lv)
                      (Any (Not . Limited) $ allDivSeq (divNatNZ (x `minus` 21) 64 SIsNotZ) lv)))))))
    -> (Any (Not . Limited) $ allDivSeq x (S lv))
postulate defini0 : (x:Nat)
  -> Either (Any (Not . Limited) $ [Just (divSeq x)])
    (Either (Any (Not . Limited) $ [Just (divSeq (divNatNZ ((x+7)*3) 4 SIsNotZ))])
      (Either (Any (Not . Limited) $ [Just (divSeq (x*6+3))])
        (Either (Any (Not . Limited) $ [Just (divSeq (x*3+6))])
          (Either (Any (Not . Limited) $ [Just (divSeq (divNatNZ ((x+1)*3) 2 SIsNotZ))])
            (Either (Any (Not . Limited) $ [Just (divSeq (x*12+9))])
              (Either (Any (Not . Limited) $ [Just (divSeq (divNatNZ ((x+3)*3) 8 SIsNotZ))])
                      (Any (Not . Limited) $ [Just (divSeq (divNatNZ (x `minus` 21) 64 SIsNotZ))])))))))
    -> (Any (Not . Limited) $ allDivSeq x 0)

-- ProofColDivSeqLvDown.idrでlvDown'を証明したからOK
postulate lvDown : (n, lv:Nat) -> P n lv -> P n (pred lv)
-- ########################################

--            from sub0xxxxx
-- ########################################
-- 01 3(6x+1) --B[1,-2]--> 3x
postulate b18x3To3x' :
  (k:Nat) -> P (S (plus (plus (plus k k) (plus k k)) (plus k k))) 1 -> P k 2

-- 02 3(18x+4) --A[6,-4]->E[2,-4]--> 3(2x)
postulate ae54x12To6x' :
  (l:Nat) -> P (S (S (plus (plus (plus (plus (plus l l) l) (plus (plus l l) l))
                              (S (plus (plus (plus l l) l) (plus (plus l l) l))))
                        (S (plus (plus (plus l l) l) (plus (plus l l) l)))))) 1
    -> P (plus l l) 3

-- 03 3(18x+10) --A[6,-4]->C[4,-4]--> 3(8x+3)
postulate ac54x30To24x9' :
  (l:Nat) -> P (S (S (S (plus (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))
                         (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))) 1
    -> P (S (S (S (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))))) 3

-- 04 3(18x+16) --A[6,-4]->B[1,-2]--> 3(4x+3)
postulate ab54x30To12x9' :
  (l:Nat) -> P (S (S (S (S (plus (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                                  (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                            (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l)))))))))))) 1
    -> P (S (S (S (plus (plus l l) (plus l l))))) 3

-- 二重否定除去
postulate dne : ((a -> Void) -> Void) = a
-- 対偶
postulate contraposition2 :
  {A, B : Nat -> Type} -> (x : Nat) -> (Not $ B x -> Not $ A x) -> (A x -> B x)
-- 05 3(3x+2) --C[4,-4]--> 3x
postulate contraC9x6To3x' :
  (j:Nat) -> Not $ P j 2 -> Not $ P (S (S (plus (plus j j) j))) 1
{-
contraC9x6To3x' j =
  rewrite definiP j                           2 in
  rewrite definiP (S (S (plus (plus j j) j))) 1 in
  rewrite dne {a = All Limited (allDivSeq (plus (plus j j) j) 2)} in
  rewrite dne {a = All Limited (allDivSeq (S (S (plus (plus (plus (plus j j) j) (S (S (plus (plus j j) j)))) (S (S (plus (plus j j) j)))))) 1)} in ?rhs
-}
c9x6To3x' :
  (j:Nat) -> P (S (S (plus (plus j j) j))) 1 -> P j 2
c9x6To3x' j = contraposition2 j $ contraC9x6To3x' j

-- 06 3(12x+3) --E[2,-4]--> 3x
postulate e36x9To3x' :
  (l:Nat) -> P (S (S (S (plus (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l))) (plus (plus l l) (plus l l)))))) 1 -> P l 2

-- 07 3(36x+9) --F[5,-2]->C[4,-4]--> 3(32x+7)
postulate fc108x27To96x21' :
  (o:Nat) -> P (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                            (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))) 1
    -> P (S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                                            (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))) 3

-- 08 3(36x+21) --F[5,-2]->B[1,-2]--> 3(16x+9)
postulate fb108x63To48x27' :
  (o:Nat) -> P (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                           (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                     (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                               (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))))))) 1
    -> P (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))))))) 3

-- 09 3(36x+33) --F[5,-2]->E[2,-4]--> 3(8x+7)
postulate fe108x99To24x21' :
  (o:Nat) -> P (S (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                              (S (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))))))
                                        (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                       (S (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))))))))))
                                  (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                 (S (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))))))))))))) 1
    -> P (S (S (S (S (S (S (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))) 3

-- 10 3(36x+6) --F[5,-2]->E[2,-4]--> 3(8x+1)
postulate fe108x18To24x3' :
  (o:Nat) ->  P (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))
                                  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))))
                            (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o))))))))) 1
    -> P (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))) 3

-- 11 3(36x+18) --F[5,-2]->C[4,-4]--> 3(32x+15)
postulate fc108x54To96x45' :
  (o:Nat) -> P (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                           (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                     (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                               (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))))))) 1
    -> P (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                                            (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))))))))))) 3

-- 12 3(36x+30) --F[5,-2]->B[1,-2]--> 3(16x+13)
postulate fb108x90To48x39' :
  (o:Nat) -> P (S (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                              (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))
                                        (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))) (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))))))  (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                 (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))))))))))))))) 1
    -> P (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))))))))))) 3

-- 13 3(36x+12) --F[5,-2]->B[1,-2]--> 3(16x+5)
postulate fb108x36To48x15' :
  (o:Nat) -> P (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                     (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))
                               (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))) 1
    -> P (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))) 3

-- 14 3(36x+24) --F[5,-2]->E[2,-4]--> 3(8x+5)
postulate fe108x72To24x15' :
  (o:Nat) ->  P (S (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                              (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                        (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))))
                                  (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))))))))) 1
    -> P (S (S (S (S (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))) 3

-- 15 3(36x+36) --F[5,-2]->C[4,-4]--> 3(32x+31)
postulate fc108x108To96x93' :
  (o:Nat) -> P (S (S (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                 (S (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))))))
                                           (S (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                             (S (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))))))))
                                     (S (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                       (S (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))))))))))))))) 1
    -> P (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                                            (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o)
            (plus o o)))))))))))))))))))))))))))))))))))) 3
-- ########################################

--            from ProofColDivSeqMain
-- ########################################
all2Sub : {pp : a -> Type} -> (xs, ys : List a)
  -> All pp ((x::xs) ++ ys) -> (pp x, All pp (xs ++ ys))
all2Sub xs ys (Cons p ps) = (p, ps)

-- これが肝
all2 : {pp : a -> Type} -> (xs, ys : List a)
  -> All pp (xs ++ ys) -> All pp xs
all2 []      ys _   = NilA
all2 (x::xs) ys prf =
  let (prf2, prf3) = all2Sub xs ys prf
  in Cons prf2 (all2 xs ys prf3)
-- ########################################


module SemVar.Data

import Data.String
import Data.List
import Data.Maybe

import Extra.String

%default total

public export
record Version where
  constructor MkVersion
  major : Int
  minor : Int
  patch : Int
  release : Maybe String
  metadata : Maybe String

%name Version version

export
Show Version where
  show version =
    join "" [ show (major version)
    , "."
    , show (minor version)
    , "."
    , show (patch version)
    , ((fromMaybe "") . map ((++) "-")) (release version)
    , ((fromMaybe "") . map ((++) "+")) (metadata version)
    ]

export
Eq Version where
  version0 == version1 =
    (major version0) == (major version1) &&
    (minor version0) == (minor version1) &&
    (patch version0) == (patch version1) &&
    (release version0) == (release version1) &&
    (metadata version0) == (metadata version1)

public export
data Requirement : Type where
  GT : Version -> Requirement
  GTE : Version -> Requirement
  LT : Version -> Requirement
  LTE : Version -> Requirement
  EQ : Version -> Requirement
  AND : Requirement -> Requirement -> Requirement
  OR : Requirement -> Requirement -> Requirement

%name Requirement requirement

-- TODO: Improve show with a pretty form, if possible
export
Show Requirement where
  show (AND req0 req1) = (show req0) ++ " " ++ (show req1)
  show (OR req0 req1) = (show req0) ++ " || " ++ (show req1)
  show (GT version) = ">" ++ (show version)
  show (GTE version) = ">=" ++ (show version)
  show (LT version) = "<" ++ (show version)
  show (LTE version) = "<=" ++ (show version)
  show (EQ version) = "=" ++ (show version)

export
Eq Requirement where
  (AND req0a req0b) == (AND req1a req1b) = req0a == req1a && req0b == req1b
  (OR req0a req0b) == (OR req1a req1b) = req0a == req1a && req0b == req1b
  (GT version0) == (GT version1) = version0 == version1
  (GTE version0) == (GTE version1) = version0 == version1
  (LT version0) == (LT version1) = version0 == version1
  (LTE version0) == (LTE version1) = version0 == version1
  (EQ version0) == (EQ version1) = version0 == version1
  _ == _ = False

export
nextMinor : Version -> Version
nextMinor version =
  MkVersion (major version) ((minor version) + 1) 0 Nothing Nothing

export
nextMajor : Version -> Version
nextMajor (MkVersion 0 minor _ _ _) =
  MkVersion 0 (minor + 1) 0 Nothing Nothing
nextMajor version =
  MkVersion ((major version) + 1) 0 0 Nothing Nothing

export
Ord Version where
  compare (MkVersion major0 minor0 patch0 release0 metadata0) (MkVersion major1 minor1 patch1 release1 metadata1) =
      case compare major0 major1 of
        EQ =>
          case compare minor0 minor1 of
            EQ =>
              case compare patch0 patch1 of
                EQ =>
                  case (release0, release1) of
                    (Just _, Nothing) =>
                      LT
                    (Nothing, Just _) =>
                      GT
                    _ =>
                      EQ
                els =>
                  els
            els =>
              els
        els =>
          els

gte : Version -> Version -> Bool
gte v0 v1 =
  let cmp = compare v0 v1
  in cmp == GT || cmp == EQ

lte : Version -> Version -> Bool
lte v0 v1 =
  let cmp = compare v0 v1
  in cmp == LT || cmp == EQ

-- TODO: We might want to make this dependently typed
export
satisfy : Requirement -> Version -> Bool
satisfy (AND reqA reqB) version = (satisfy reqA version) && (satisfy reqB version)
satisfy (OR reqA reqB) version = (satisfy reqA version) || (satisfy reqB version)
satisfy (GTE v0) v1 = v1 `gte` v0
satisfy (GT v0) v1 = compare v1 v0 == GT
satisfy (LTE v0) v1 = v1 `lte` v0
satisfy (LT v0) v1 = compare v1 v0 == LT
satisfy (EQ v0) v1 = compare v1 v0 == EQ
satisfy _ _ = False


data Name : Type where
  MN : Int -> Name

data IsVar : Name -> List Name -> Type where
  First : IsVar n (n :: ns)
  Later : IsVar n ns -> IsVar n (m :: ns)

data Expr : List Name -> Type where
  CLocal : (prf : IsVar x vars) -> Expr vars

data FunDecl : Type where
  MkFunDecl : (vars : List Name) -> Expr vars -> FunDecl

funDeclWorks : List FunDecl
funDeclWorks = [MkFunDecl [MN 0] (CLocal First)]

foo : Expr [MN 0]
foo = CLocal First

dpairFails : List (vars : List Name ** Expr vars)
dpairFails = [([MN 0] ** CLocal First)]

dpairWithExtraInfoWorks : List (vars : List Name ** Expr vars)
dpairWithExtraInfoWorks = [([MN 0] ** CLocal {x=MN 0} (First {ns=[]}))]

dpairWithExtraInfoBad : List (vars : List Name ** Expr vars)
dpairWithExtraInfoBad = [([MN 0] ** CLocal {x=MN 0} (First {ns=[MN 0]}))]


module Main
import Data.Vect

public export

len : Vect n a -> Int
len {n=Z} [] = 0
len {n=S k} (with Vect x::xs) = 1 + len xs

v : Vect ?n Int
v = [1, 2, 3]

main : IO ()
main = do
    putStrLn . show $ len v
    putStrLn .show  $ with List ["a"]
    pure ()


||| A MonadRef instance with heap and locations indexed by a universe.
|||
||| Note:
||| - We can't make an instance `MonadRef (Loc es) (RefT es es' m)`
|||   because `Loc es : Ty u -> Type` instead of `Type -> Type`...
module Experiment.TypedHeap

import public Experiment.RefUniverseConstraint

%default total
%access public export

%hide Language.Reflection.Ref
%hide Language.Reflection.Universe

-- Implementation --------------------------------------------------------------

-- Types --

||| The shape of a heap.
|||
||| Determines the type of data stored at every memory location.
||| Heaps have a length `k` and every location has a certain type `t` from the universe `u`.
Shape : {u : Universe t} -> Type
Shape {t} = List t

||| Hetrogenious heap indexed by a `Shape`.
|||
||| `Nil` is the empty heap.
||| `(::)` allocates a value `a` of type `typeOf e` on a heap `as` of shape `es`
||| to construct a heap of shape `e :: es`.
|||
||| Note: corresponds to an universe indexed variant of `Data.HVect`.
data Heap : {u : Universe t} -> (es : Shape {u}) -> Type where
  Nil  : Heap []
  (::) : (a : typeOf @{u} e) -> (as : Heap {u} es) -> Heap {u} (e :: es)

||| Location on the heap.
|||
||| A value of type `Loc es e` corresponds to a proof that a value of type `typeOf e`
||| is stored in a heap of shape `es`.
||| `Here` means it is stored at this location.
||| `There` means it is stored a bit further on the heap.
|||
||| Note: corresponds to an universe indexed variant of `Data.Vect.Elem`.
data Loc : {u : Universe t} -> (es : Shape {u}) -> (e : t) -> Type where
  Here  : Loc (e :: es) e
  There : (later : Loc {u} es e) -> Loc {u} (e' :: es) e

data RefT : {u : Universe t} -> (es : Shape {u}) -> (es' : Shape {u}) -> (m : Type -> Type) -> (a : Type) -> Type where
  Pure  : (x : a) -> RefT es es m a
  Bind  : (this : RefT {u} es es' m a) -> (next : a -> RefT {u} es' es'' m b) -> RefT {u} es es'' m b

  New   : (x : typeOf @{u} e) -> RefT {u} es (e :: es) m (Loc {u} (e :: es) e)
  Read  : (l : Loc {u} es e) -> RefT {u} es es m (typeOf @{u} e)
  Write : (l : Loc {u} es e) -> (x : typeOf @{u} e) -> RefT {u} es es m ()

Ref : {u : Universe t} -> (es : Shape {u}) -> (es' : Shape {u}) -> (a : Type) -> Type
Ref {u} es es' = RefT {u} es es' Identity

-- Semantics --

lookup : (u : Universe t) => Loc es e -> Heap es -> typeOf @{u} e
lookup _         []        impossible
lookup (Here)    (x :: _)  = ?h
-- lookup (There l) (_ :: xs) = lookup l xs

{-------------------------------------------------------------------------------

update : Loc es e -> typeOf @{u} e -> Heap es -> Heap es
update _         _ []        impossible
update (Here)    y (_ :: xs) = y :: xs
update (There l) y (x :: xs) = x :: update l y xs

runT : Monad m => RefT es es' m a -> Heap es -> m ( a, Heap es' )
runT (Pure x)         xs = pure ( x, xs )
runT (Bind this next) xs = do
  ( this, xs' ) <- runT this xs
  runT (next this) xs'
runT (New x)          xs = pure ( Here, x :: xs )
runT (Read l)         xs = pure ( lookup l xs, xs )
runT (Write l x)      xs = pure ( (), update l x xs )

run : Ref es es' a -> Heap es -> ( a, Heap es' )
run r = runIdentity . runT r

eval : Ref es es' a -> Heap es -> a
eval mut = fst . run mut

exec : Ref es es' a -> Heap es -> Heap es'
exec mut = snd . run mut

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

Functor f => Functor (RefT es es' f) where
  map f fa = ?holeFunctor

Applicative f => Applicative (RefT es es' f) where
  pure a = ?holePureApplicative

  f <*> fa = ?holeApplyApplicative

Monad m => Monad (RefT es es' m) where
  fa >>= f = ?holeMonadBind

Monad m => MonadRef u (Loc es) (RefT es es' m) where
  ref x = ?holeMonadRefRef
  deref l = ?holeMonadRefDeref
  assign l x = ?holeMonadRefAssign

-------------------------------------------------------------------------------}


module Main

import Average
import Palindrome

counts : String -> (Nat, Nat)
counts s = (length (words s), length s)

top_ten : Ord a => List a -> List a
top_ten xs = take 10 (reverse (sort xs))

over_length : Nat -> List String -> Nat
over_length n strs = length (filter (\w => length w > n) strs)

describe : String -> String
describe str = "The average word length is: "
  ++ show (average str) ++ ".\n"
  ++ "It " ++ (if palindrome 10 str then "is" else "is not") ++ " a palindrome.\n"

main : IO ()
main = repl "Enter a string:"
            describe


-- ----------------------------------------------------------------- [ Set.idr ]
-- Module    : Set.idr
-- Copyright : (c) 2015,2016 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| Testing Stacks using silly stupid tests
module Data.AVL.Test.Set

import Test.Unit
import Test.Random.Values

import Data.AVL.Set

%access export

list1 : List Integer
list1 = rndListIntU 123456789 (0,100) 30

list2 : List Integer
list2 = rndListIntU 987654321 (101,200) 30

set1' : Set Integer
set1' = Set.insert 101 $ Set.fromList list1

set1 : Set Integer
set1 = Set.fromList list1

set2 : Set Integer
set2 = Set.fromList list2

-- ------------------------------------------------------------ [ Construction ]
partial
testBuilding : IO Bool
testBuilding = genericTest
    (Just "List, Building" )
    (Set.size set1 == 30 && (sorted $ Set.toList $ Set.fromList list1))
    True
    (==)

-- ---------------------------------------------------------------- [ Updating ]

partial
testUpdate : IO Bool
testUpdate = genericTest
    (Just "Insert")
    (Set.size set1' == 31 && Set.size set1 == 30)
    True
    (==)

partial
testMerge : IO Bool
testMerge = genericTest
    (Just "Union")
    (Set.size $ Set.union set1 set2)
    (60)
    (==)

partial
testDiff : IO Bool
testDiff = genericTest
   (Just "Difference")
   (Set.toList $ Set.difference (Set.fromList [1,2,3]) (Set.fromList [2,3,4]))
   [1]
   (==)

partial
testIntersection : IO Bool
testIntersection = genericTest
    (Just "Intersection")
    (Set.size $ Set.intersection set1 set1)
    30
    (==)

partial
testContains : IO Bool
testContains = genericTest
    (Just "Contains")
    (Set.contains 102 $ set1)
    (False)
    (==)

partial
runTest : IO ()
runTest = do
    putStrLn "Testing Set"
    putStrLn infoLine
    NonReporting.runTests [
        testBuilding
      , testUpdate
      , testMerge
      , testContains
      , testDiff
      , testIntersection
    ]

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


module Examples.AOC2

import Data.String
import Data.Nat

import Stream
import System
import System.File

record Pos where
  constructor MkPos
  aim        : Int32
  depth      : Int32
  horizontal : Int32

initialPos : Pos
initialPos = MkPos 0 0 0

adjustPos : Pos -> String -> Pos
adjustPos (MkPos a d h) s = case words $ trim s of
  ["forward",v] => MkPos a d (h + cast v)
  ["down",v]    => MkPos a (d + cast v) h
  ["up",v]      => MkPos a (d - cast v) h
  _             => MkPos a d h

adjustPos2 : Pos -> String -> Pos
adjustPos2 (MkPos a d h) s = case words $ trim s of
  ["forward",v] => MkPos a (d + a * cast v) (h + cast v)
  ["down",v]    => MkPos (a + cast v) d h
  ["up",v]      => MkPos (a - cast v) d h
  _             => MkPos a d h

export
part1 : IO ()
part1 = ignore $ withLines "resources/aoc2a" $ \ls => do
  MkPos a d h <- run $ fold_ adjustPos initialPos id ls
  putStrLn "Day2, Result A: \{show $ d * h} (Depth: \{show d}, Pos: \{show h})"

export
part2 : IO ()
part2 = ignore $ withLines "resources/aoc2a" $ \ls => do
  MkPos a d h <- run $ fold_ adjustPos2 initialPos id ls
  putStrLn "Day2, Result B: \{show $ d * h} (Depth: \{show d}, Pos: \{show h})"


import Data.Vect
import Decidable.Equality

myExactLength : {m : _} -> (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
myExactLength len input = case decEq m len of
                                 Yes Refl => Just input
                                 No contra => Nothing


module Kan
import Control.Monad.Identity
import Data.Morphisms

data Ran : (f : Type -> Type) -> (g : Type -> Type) -> (a : Type) -> Type where
  R : ({b : Type} -> (a -> f b) -> g b) -> Ran f g a

data Lan : (f : Type -> Type) -> (g : Type -> Type) -> (a : Type) -> Type where
  L : (f b -> a) -> g b -> Lan f g a

Functor (Ran f g) where
  map f ran = R (\k => let (R f') = ran in f' (k . f))

Functor (Lan f g) where
  map f (L g h) = L (f . g) h

Yoneda : (Type -> Type) -> Type -> Type
Yoneda f a = Ran Identity f a

CoYoneda : (Type -> Type) -> Type -> Type
CoYoneda f a = Lan Identity f a

Codensity : (Type -> Type) -> Type -> Type
Codensity m a = Ran m m a

Reducer : Type -> Type
Reducer a = Ran Endomorphism Endomorphism a


foo : Int -> Int
foo x = case isLT of
            Yes => x*2
            No => x*4
    where
       data MyLT = Yes | No

       isLT : MyLT
       isLT = if x < 20 then Yes else No

even : Nat -> Bool
even Z = True
even (S k) = odd k where
  odd : Nat -> Bool
  odd Z = False
  odd (S k) = even k

test : List Nat
test = [c (S 1), c Z, d (S Z)]
  where c : Nat -> Nat
        c x = 42 + x

        d : Nat -> Nat
        d y = c (y + 1 + z y)
              where z : Nat -> Nat
                    z w = y + w


-- -------------------------------------------------------------- [ Common.idr ]
-- Module      : Common
-- Description : Common things for advanced crypto
-- Copyright   : (c) Jan de Muijnck-Hughes
-- License     : see LICENSE
-- --------------------------------------------------------------------- [ EOF ]
module Crypto.Adv.Common

namespace BPolicy
    data BPolicy : Type where
      Leaf : (value : a) -> BPolicy
      Or   : (l : BPolicy) -> (r : BPolicy) -> BPolicy
      And  : (l : BPolicy) -> (r : BPolicy) -> BPolicy

namespace TPolicy
  data TPolicy : (threshold : Nat) -> (count : Nat) -> Type where
    TLeaf      : (value : a) -> TPolicy 1 1
    NKPolicy   : (k : Nat) -> (children : Vect n (TPolicy t m)) -> TPolicy k n
    OneKPolicy : (children : Vect n (TPolicy t m)) -> TPolicy 1 n
    KKPolicy   : (children : Vect n (TPolicy t m)) -> TPolicy n n

foobar : BPolicy
foobar = Or (And
              (Or (Leaf "a:xxx0") (Leaf "a:xx0x"))
              (Leaf "a:x0xx"))
            (Leaf "a:0xxx")

foobar' : TPolicy 1 2
foobar' = OneKPolicy [KKPolicy
                      [OneKPolicy
                          [TLeaf "a:xx0", TLeaf "a:xx0x"],
                       TLeaf "a:x0xx"],
                      TLeaf "a:0xxx"]
-- 1of2 ( 2of2 ( 1of2 ( a:xxx0 , a:xx0x ) , a:x0xx ) , a:0xxx )


module Control.Functor.Indexed

infixl 1 <<&>>
infixr 4 <<$>>, <<$, $>>

||| An Indexed Functor.
||| This interface is indexed backwards of similar utlities in Haskell
||| to make it more readily compatible with the evolution of a type from
||| Indexed simply on values (or types) but also on functions that depend on
||| those values.
|||
||| An indexed functor where the mappable type comes last does not later
||| refactor into what this library calls a TransitionIndexed type as readily.
public export
interface IndexedFunctor x y (0 f : Type -> x -> y -> Type) | f where
  total
  map : {0 j : x} -> {0 k : y} -> (a -> b) -> f a j k -> f b j k

||| Map for indexed functors.
public export
(<<$>>) : IndexedFunctor x y f => (a -> b) -> f a j k -> f b j k
(<<$>>) = map

||| Flipped version of `<<$>>`
public export
(<<&>>) : IndexedFunctor x y f => f a j k -> (a -> b) -> f b j k
(<<&>>) = flip (<<$>>)

||| Run something for effects, replacing the return value afterwards.
public export
(<<$) : IndexedFunctor x y f => b -> f a j k -> f b j k
(<<$) = map . const

||| Flipped version of `<<$`
public export
($>>) : IndexedFunctor x y f => f a j k -> b -> f b j k
($>>) = flip (<<$)

||| Run something for effects, throwing away the return value.
%inline
public export
ignore : IndexedFunctor x y f => f a j k -> f () j k
ignore = map (const ())


data Test : Type where
     MkTest : Integer -> Integer -> Test

etaGood1 : MkTest = (\x => \y => MkTest ? ?)
etaGood1 = Refl

etaGood2: (MkTest 1) = (\x => MkTest ? x)
etaGood2 = Refl

etaGood3: (f : a -> b) -> f = (\x => f x)
etaGood3 f = Refl

etaBad : MkTest = (\x : Nat => \y => MkTest ? ?)
etaBad = Refl


f : (a : Int) => Int
f @{x} = x

g : Int
g = f {a=4}

h : Int
h = f @{5}


module Capabilities

-- Inspired by http://okmij.org/ftp/Computation/lightweight-static-guarantees.html

interface Sortable (f : Type -> Type) where
  Sorted : (a : Type) -> (a -> a -> Ordering) -> Type

  sortBy : (cmp : a -> a -> Ordering) -> f a -> Sorted a cmp
  mergeBy : (cmp : a -> a -> Ordering) -> Sorted a cmp  -> Sorted a cmp -> Sorted a cmp
  get : Sorted a cmp -> f a

Sortable List where
  Sorted a cmp = List a

  sortBy cmp xs = List.sortBy cmp xs
  mergeBy cmp xs ys = List.mergeBy cmp xs ys
  get xs = xs

example : Sortable f => (cmp : a -> a -> Ordering) -> f a -> f a -> f a
example @{sortable} cmp xs ys =
  let sxs = sortBy cmp xs in
  let sys = sortBy cmp ys in
  let sms = mergeBy @{sortable} cmp sxs sys in
  get sms


module Replica.Other.Free

%default total

public export
data Ap : (Type -> Type) -> Type -> Type where
  Pure : a -> Ap f a
  MkAp : f a -> Ap f (a -> b) -> Ap f b

export
Functor (Ap f) where
  map func (Pure x) = Pure (func x)
  map func (MkAp x y) = MkAp x (map (func .) y)

export
Applicative (Ap f) where
  pure = Pure
  (<*>) (Pure y) x = map y x
  (<*>) e@(MkAp y z) x = MkAp y $ assert_smaller e (map flip z) <*> x

export
runAp : Applicative g => (forall x. f x -> g x) -> Ap f c -> g c
runAp func (Pure x) = pure x
runAp func (MkAp x y) = runAp func y <*> func x

export
runApM : Monoid m => (forall x. f x -> m) -> Ap f c -> m
runApM func (Pure x) = neutral
runApM func (MkAp x y) = runApM func y <+> func x

export
liftAp : f a -> Ap f a
liftAp x = MkAp x (Pure id)


module TryIndex

import Data.Vect

%default total

tryIndex : { n : _ } -> Integer -> Vect n elem -> Maybe elem
tryIndex m xs = case integerToFin m n of
                     Nothing => Nothing
                     Just idx => Just $ index idx xs

vi : Vect 5 Int
vi = [1, 2, 3, 4, 5]


module Main

import Depling
import Depling.TypeCheck
import Depling.PrettyPrint
import Depling.Incr
import Depling.Elevate
import Data.Vect
import Data.Fin
import Utils

lℕℂ : DCon 0
lℕℂ = DConV "ℕ" [] 𝕋

lℕ : DAST n
lℕ = ℂ lℕℂ []

lzℂ : DCon 0
lzℂ = DConV "z" [] lℕ

lz : DAST n
lz = ℂ lzℂ []

lsℂ : DCon 1
lsℂ = DConV "s" [lℕ] lℕ

ls : DAST n
ls = λ lℕ $ ℂ lsℂ [ʌ 0]

lp : DAST n
lp =
	𝔽 lℕ (λT lℕ lℕ) $
		ℙ (ʌ 0) lzℂ (λ lℕ $ ʌ 0) $
		ℙ (ʌ 0) lsℂ (λ lℕ $ ʌ 3 =!= ʌ 1 =!= (ls =!= ʌ 0)) $
		𝔹 (λT lℕ lℕ)

lco : DAST n
lco = λ 𝕋 $ λ (λT (ʌ 0) 𝕋) $ λ (λT (ʌ 1) (ʌ 1 =!= ʌ 0)) $ λ 𝕋 $ λ (λT (ʌ 0) (ʌ 4)) $ λ (ʌ 1) $ ʌ 3 =!= (ʌ 1 =!= ʌ 0)

llℂ : DCon 1
llℂ = DConV "l" [𝕋] 𝕋

ll : DAST n
ll = λ 𝕋 $ ℂ llℂ [ʌ 0]

lnℂ : DCon 1
lnℂ = DConV "n" [𝕋] $ ll =!= ʌ 0

ln : DAST n
ln = λ 𝕋 $ ℂ lnℂ [ʌ 0]

lcℂ : DCon 3
lcℂ = DConV "c" [𝕋, ʌ 0, ll =!= ʌ 1] $ ll =!= ʌ 2

lc : DAST n
lc = λ 𝕋 $ λ (ʌ 0) $ λ (ll =!= ʌ 1) $ ℂ lcℂ [ʌ 2, ʌ 1, ʌ 0]

lrepeat : DAST n
lrepeat = λ 𝕋 $ 𝔽 (ʌ 0) (ll =!= ʌ 1) $ lc =!= ʌ 2 =!= ʌ 0 =!= (ʌ 1 =!= ʌ 0)

lcycle : DAST n
lcycle =
	-- a : Type
	λ 𝕋 $
		-- orig : List a
		λ (ll =!= ʌ 0) $
			-- R : List a -> List a
			-- l : List a
			(𝔽 (ll =!= ʌ 1) (ll =!= ʌ 2) $
				-- a' : Type -- a' = a
				ℙ (ʌ 0) lnℂ (ʌ 2 =!= ʌ 3) $
				-- a' : Type -- a' = a
				-- h : a
				-- t : List a
				ℙ (ʌ 0) lcℂ (lc =!= ʌ 6 =!= ʌ 1 =!= (ʌ 4 =!= ʌ 0)) $
				𝔹 $ ll =!= ʌ 3
			) =!= ʌ 0

lhead : DAST n
lhead = λ 𝕋 $ λ (ll =!= ʌ 0) $ ℙ (ʌ 0) lcℂ (ʌ 1) $ 𝕌 "head of empty list" (ʌ 1)

ltail : DAST n
ltail = λ 𝕋 $ λ (ll =!= ʌ 0) $ ℙ (ʌ 0) lcℂ (ʌ 0) $ ʌ 0

leqℂ : DCon 4
leqℂ = DConV "=" [𝕋, ʌ 0, 𝕋, ʌ 0] 𝕋

leq : DAST n
leq = λ 𝕋 $ λ (ʌ 0) $ λ 𝕋 $ λ (ʌ 0) $ ℂ leqℂ [ʌ 3, ʌ 2, ʌ 1, ʌ 0]

lreflℂ : DCon 2
lreflℂ = DConV "Refl" [𝕋, ʌ 0] $ ℂ leqℂ [ʌ 1, ʌ 0, ʌ 1, ʌ 0]

lrefl : DAST n
lrefl = λ 𝕋 $ λ (ʌ 0) $ ℂ lreflℂ [ʌ 1, ʌ 0]

lThe : DAST n
lThe = λ 𝕋 $ λ (ʌ 0) $ ʌ 0

lPlusSuccRightSucc : DAST n
lPlusSuccRightSucc {n} =
	-- recurse : Nat -> Nat -> Nat
	-- left : Nat
	𝔽 lℕ (λT lℕ lℕ) $
		-- right : Nat
		λ lℕ $
			ℙ (ʌ 1) lzℂ (ℂ lreflℂ [lℕ, ℂ lsℂ [ʌ 0]]) $
			-- left : Nat
			-- ℙ (ʌ 1) lsℂ (
				-- lThe =!= t =!= ℂ lreflℂ [lℕ, ℂ lsℂ [ʌ 0]]
				𝕌 "wat" t
				-- ℙ (ʌ 3 =!= ʌ 0 =!= ʌ 1) lreflℂ (
					-- ℂ lreflℂ [lℕ, ℂ lsℂ [ʌ 0]]
				-- ) $
				-- 𝕌 "wat" $ elevate {gte=ltePlus'' {n=S$ S$ S$ n} {a=1}} t
			-- ) $
			-- 𝕌 "wat" t
	where
	t : DAST (S$ S$ S$ n)
	--  ℂ  =   [Nat, plus   left    ℂ succ [right], Nat, ℂ succ [plus   left    right]]
	t = ℂ leqℂ [lℕ , lp =!= ʌ 1 =!= ℂ lsℂ  [ʌ 0  ], lℕ , ℂ lsℂ  [lp =!= ʌ 1 =!= ʌ 0  ]]

ltest' : DAST n
ltest' = λ (ℂ leqℂ [lℕ, lz, lℕ, lz]) $ ʌ 0

ltest : DAST n
ltest = ltest' =!= ℂ lreflℂ [𝕋, 𝕋]

ppTypeError : DTypeError -> String
ppTypeError (DTypeErrorV e ts) =
	(pp_n DPOpen [] $ replace (sym $ plusZeroRightNeutral _) e) ++ ":\n"
	++ (unlines $ map (("  " ++) . pp_n DPOpen [] . replace (sym $ plusZeroRightNeutral _)) ts)

main : IO ()
main = putStrLn $ pp DPOpen [] $ lPlusSuccRightSucc


module Main

import Data.Vect
import System

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

readNumbers : IO (Maybe (Nat, Nat))
readNumbers = do
  Just num1_ok <- readNumber | Nothing => pure Nothing
  Just num2_ok <- readNumber | Nothing => pure Nothing
  pure (Just (num1_ok, num2_ok))

countdown : (secs : Nat) -> IO ()
countdown Z = putStrLn "Left off!"
countdown (S secs) = do
  putStrLn (show (S secs))
  usleep 1000000
  countdown secs

countdowns : IO ()
countdowns = do
  putStr "Enter a starting number: "
  Just startNum <- readNumber
     | Nothing => do putStrLn "Invalid input"
                     countdowns
  countdown startNum
  putStr "Another (y/n)? "
  yn <- getLine
  if yn == "y"
    then countdowns
    else pure ()

readVectLen : (len : Nat) -> IO (Vect len String)
readVectLen Z = pure []
readVectLen (S k) = do
  x <- getLine
  xs <- readVectLen k
  pure (x :: xs)

anyVect : (n : Nat ** Vect n String)
anyVect = (3 **  ["a", "b", "c"])

readVect : IO (n : Nat ** Vect n String)
readVect = do
  x <- getLine
  if x == ""
    then pure (0 ** [])
    else do
      (k ** xs) <- readVect
      pure (S k ** x :: xs)

zipInputs : IO ()
zipInputs = do
  putStrLn "Enter the first vector (blank line to end): "
  (len1 ** vect1) <- readVect
  putStrLn "Enter the second vector (blank line to end): "
  (len2 ** vect2) <- readVect
  case exactLength len1 vect2 of
    Nothing => putStrLn "Vectors are different lengths"
    Just vect2' => printLn (zip vect1 vect2')

main : IO ()
main = do
  countdowns
  res3 <- readVectLen 3
  print res3
  print anyVect
  zipInputs


module Data.Time.Clock.System

import Data.Time.Clock.Internal.SystemTime
import Data.Time.Clock.Internal.UTCTime
import Data.Time.Clock.Internal.DiffTime
import Data.Time.Calendar.Days

-- | The day of the epoch of 'SystemTime', 1970-01-01
export
systemEpochDay: Day
systemEpochDay = MkModifiedJulianDay 40587

export
get_nano_res: Integer
get_nano_res = 1000000000

export
systemToUTCTime: SystemTime -> UTCTime
systemToUTCTime (MkSystemTime seconds nanoseconds) =
  let
    days = seconds `div` 86400
    day = addDays days systemEpochDay
    timeSeconds = seconds `mod` 86400
    -- TODO: Add nanoseconds
    --timeNanoseconds = timeSeconds * get_nano_res -- TODO: add nanoseconds + ()
    time = picosecondsToDiffTime (timeSeconds) -- * 1000)
  in
    MkUTCTime day time

-- TODO: Currently we do no capture nanoseconds, therefore coversion to System time looses precision
-- utcToSystemTime: UTCTime -> SystemTime
-- utcToSystemTime (MkUTCTime day diffTime) =
--   let
--     days = diffDays day systemEpochDay
--     timePicoSeconds = diffTimeToPicoseconds diffTime
--     timeNanoseconds = timePicoSeconds `div` 1000
--     timeSeconds = if timeNanoseconds >= 86400000000000 then 86399 else timeNanoseconds `div` get_nano_res
--     seconds = days * 86400 + timeSeconds
--   in
--     MkSystemTime seconds 0


||| This module is about *aliases* for pins that belong to some hardware protocol (bus)
module Arduino.Protocols

import Arduino.Boards

import Data.Vect
import Data.Vect.Quantifiers

%default total
%access public export

-----------------
--- Protocols ---
-----------------

-- TODO to think whether can pins used in different protocols intersect with each other?
-- TODO to think why digital, PWM, DAC and ADC are not just yet another protocols?

record HardwareProtocol where
  constructor MkProtocol
  protocolName : String
  protocolPinsCount : Nat

interface HasDigitalPins board => HasProtocol (0 prot : HardwareProtocol) (0 board : Board) where
  ProtocolPinGroupsCount : Nat

  ProtocolPins : Fin ProtocolPinGroupsCount -> Vect (protocolPinsCount prot) Pin

  AllProtocolPins : Vect (ProtocolPinGroupsCount * protocolPinsCount prot) Pin
  AllProtocolPins = ?flattenSomehow -- map ProtocolPins (allFinsTo ProtocolPinGroupsCount)
    where
      allFinsTo : (n : Nat) -> Vect n (Fin n)
      allFinsTo Z     = []
      allFinsTo (S n) = last :: map weaken (allFinsTo n)

  AllProtocolPinsDigital : All (CanBeDigital {board}) AllProtocolPins
  AllProtocolPinsDifferent : AllDiffer AllProtocolPins

--- UART ---

UART : HardwareProtocol
UART = MkProtocol "UART" 2

TX : HasProtocol UART board => Fin (ProtocolPinGroupsCount {prot=UART} {board}) -> Pin
RX : HasProtocol UART board => Fin (ProtocolPinGroupsCount {prot=UART} {board}) -> Pin

TX {board} = Data.Vect.index 0 . ProtocolPins {prot=UART} {board}
RX {board} = Data.Vect.index 1 . ProtocolPins {prot=UART} {board}

--- I2C ---

I2C : HardwareProtocol
I2C = MkProtocol "I2C" 2

SDA : HasProtocol I2C board => Fin (ProtocolPinGroupsCount {prot=I2C} {board}) -> Pin
SCL : HasProtocol I2C board => Fin (ProtocolPinGroupsCount {prot=I2C} {board}) -> Pin

SDA {board} = Data.Vect.index 0 . ProtocolPins {prot=I2C} {board}
SCL {board} = Data.Vect.index 1 . ProtocolPins {prot=I2C} {board}

--- SPI ---

SPI : HardwareProtocol
SPI = MkProtocol "SPI" 4

MISO : HasProtocol SPI board => Fin (ProtocolPinGroupsCount {prot=SPI} {board}) -> Pin
MOSI : HasProtocol SPI board => Fin (ProtocolPinGroupsCount {prot=SPI} {board}) -> Pin
SCK  : HasProtocol SPI board => Fin (ProtocolPinGroupsCount {prot=SPI} {board}) -> Pin
SS   : HasProtocol SPI board => Fin (ProtocolPinGroupsCount {prot=SPI} {board}) -> Pin

MISO {board} = Data.Vect.index 0 . ProtocolPins {prot=SPI} {board}
MOSI {board} = Data.Vect.index 1 . ProtocolPins {prot=SPI} {board}
SCK  {board} = Data.Vect.index 2 . ProtocolPins {prot=SPI} {board}
SS   {board} = Data.Vect.index 3 . ProtocolPins {prot=SPI} {board}


import Data.Vect

distrL : a -> List b -> List (a, b)
distrL a = map (a,)

distrR : b -> List a -> List (a, b)
distrR b = map (, b)

-- closeVect : List (n ** Vect n Nat)
-- closeVect = map (** flip replicate 3) [0..10]

insert : List (Nat,Nat,Nat,Nat)
insert = map (\ f => f (the Nat 0) (the Nat 1))
         [(,,2,3), (2,,,3), (2,3,,)]


||| Spec: https://webassembly.github.io/spec/core/syntax/modules.html#tables
module WebAssembly.Structure.Modules.Tables

import WebAssembly.Structure.Types

import Decidable.Equality

-- Definition

public export
record Table where
  constructor MkTable
  type : TableType

-- Equality

total public export
lemma_table__type_injective : ((t1 = t2) -> Void) -> (MkTable t1 = MkTable t2) -> Void
lemma_table__type_injective t1_not_t2 Refl = t1_not_t2 Refl

-- Decidable Equality

public export
implementation DecEq Table where
  decEq (MkTable t1) (MkTable t2) = case decEq t1 t2 of
    No t1_not_t2 => No $ lemma_table__type_injective t1_not_t2
    Yes Refl     => Yes Refl


module Main
import Data.Vect
%hide natToFin
%hide cmp
%hide index
%default total

public export
interface Indexable c i where
    eltype : Type
    index' : i -> c -> eltype

implementation Indexable (Vect k t) (Fin k) where
    eltype = t
    index' FZ (x :: xs) = x
    index' (FS k) (x :: xs) = index' k xs

int_vec : Vect 2 Int
int_vec = [2, 3]

cmp : Nat -> Nat -> Ordering
cmp Z Z = EQ
cmp Z _ = LT
cmp _ Z = GT
cmp (S k1) (S k2) = cmp k1 k2

-- -> {auto p: cmp m n = LT}

filter' : (a -> Bool) -> Vect n a -> (p ** Vect p a)
filter' p [] = ( 0 ** [] )
filter' p (x :: xs) with (filter' p xs)
   | ( a ** xs' ) = if (p x) then ( (S a) ** x :: xs' ) else ( a ** xs' )


import Data.SortedMap
import Data.List

f : Ord k => SortedMap k v -> List (k, v)
f m = case sortBy (\(x, _), (y, _) => compare x y) (SortedMap.toList m) of
    as => as

g : Ord k => SortedMap k v -> List (k, v)
g m = let kvs = toList m in
          case sortBy (\(x, _), (y, _) => compare x y) kvs of
               as => as


module Simple

infixr 10 ::

data Nat = Z | S n

data List : Type -> Type where
  Nil : List a
  Cons : a -> List a -> List a

corecord Stream a where
  head : a
  tail : Stream a
  constructor (::)

corecord BisimStream a (s : Stream a) (t : Stream a) where
   phead : head s = head t
   ptail : BisimStream a (tail s) (tail t)

record Foo a where
  xs : List a


import Data.Vect
||| Modeled from https://eb.host.cs.st-andrews.ac.uk/drafts/impldtp.pdf page 10

data ANTContext : {n: Nat} -> Type

data Binding : ANTContext -> Type

||| All contexts that are definable using this structure are valid.
|||
||| They can have variables added into them as specified by Binding
data ANTContext : {n: Nat} -> Type where
  Empty : ANTContext {n=0}
  AddBinding : (ctx : ANTContext {n=n})
                -> (b : Binding ctx)
                -> ANTContext {n=S n}

data ANTExp : ANTContext -> Type

||| This simple returns TypeN
||| Since data constructors can't recursively reference each other, this
||| breaks the loop
mkTypeN : (g : ANTContext) -> Nat -> ANTExp g

typeForExp : {g : ANTContext} -> ANTExp g -> ANTExp g

||| Context B encompass context A if any expression that is implied
||| by A can also be implied by B. This means that no matter what vars
||| are added to a context, it still implies *at least* the same
||| expressions as it did before. B is a descendent of A
|||
||| In other words, an *inner* context can reference anything from
||| an *outer* context, and all context applied in the outer also
||| apply to the inner.
|||
||| Ex: let x = (15 : Int) in (let y = 3 : Int) in x + y)
|||                           ^^^^^^^^^^^^^^^^^^^^^^^^^^^ -- outer context (A), x is defined
|||      inner context (B), x and y are defined -- ^^^^^
data ContextEncompasses : (des : ANTContext) -> (anc : ANTContext)
     -> Type where
  Self : {self : ANTContext} -> ContextEncompasses self self
  Child : (b : Binding anc) -> {prf : ContextEncompasses des anc}
         -> ContextEncompasses des (AddBinding anc b)

||| Represents a variable into the context. Note this is not the same thing
||| as creating a Lam/Pi/Let Expression. It is rather the resulting
||| context to be used *within* the body of a lam/pi/let expression that
||| has been created. Ex:
|||
||| Let x = (16 : Int) in (....)
|||                        ^^^^-- binding should be added to context for this part
|||
||| See ANTExp.Lam to create a Lam, etc.
|||
data Binding : (ctx : ANTContext) -> Type where
  |||  G |- S' : Type(i)
  |||  ------------------
  |||  G;\x:S' |- valid
  LamBinding : (S' : ANTExp ctx)
            -> (typeForExp S' = (mkTypeN ctx i)) -> Binding ctx

  |||  G |- S' : Type(i)
  |||  ------------------
  |||  G;forall x:S' |- valid
  PiBinding : (S' : ANTExp ctx)
            -> (typeForExp S' = (mkTypeN ctx i)) -> Binding ctx

  |||  G |- S' : Type(i)    G |- s : S'
  |||  --------------------------------
  |||  G;let x = s : S' |- valid
  LetBinding : (S' : ANTExp ctx)
            -> (typeForExp S' = (mkTypeN ctx i))
            -> (s : ANTExp ctx)
            -> (typeForExp s = S')
            -> Binding ctx

--isEquivalentExp : ANTExp des -> ANTExp anc -> ContextEncompasses des anc -> Type

alphaEq : ANTExp g -> ANTExp g -> Type

||| This is a *valid* expression of the context. An expression can
||| only be created if a context implies it by running one or more of
||| its base rules
|||
||| Basically if a rule ends in:
|||    ....
|||    -------
|||    G |- x
||| then this represents that "G |- x" is true, according to the rules
data ANTExp : ANTContext -> Type where

  ||| This is our own made up rule. It's not in the design doc, but it
  ||| inherently implied:
  |||
  |||  G |- X
  |||  ---------
  |||  G;a |- X
  |||
  ||| It means that if you add a new variable, a to G, everything that
  ||| G implied before is still valid
  ChildContextImpliesSame :
    (parent : ANTContext) -> (b : Binding parent) -> ANTExp parent -> ANTExp (AddBinding parent b)

  |||       G |- valid
  |||  Type ------------
  |||       G |- Type(n) : Type(n+1)
  ||| Part 1: Every context implies Type(n) exists
  ||| Part 2 of this, that TypeN has a Type(n+1) is in typeForExpr
  TypeN : (g : ANTContext) -> (n : Nat) -> ANTExp g

  |||       (\x:S) in G
  |||  Var1 ------------
  |||       G |- x : S
  |||
  |||       (forall x:S) in G
  |||  Var2 ------------
  |||       G |- x : S
  |||
  |||       (let x = s : S) in G
  |||  Var3 ------------
  |||       G |- x : S
  ||| Part 1: A valid var lookup
  ||| Part 2 of this, that x has a type of S, is in typeForExpr
  Var : (g : ANTContext {n} ) -> (n : Fin n) -> ANTExp g

  |||         G;forall x:S' |- T : Type(m)    G |- S' : Type(n)
  ||| Forall  ------------------------------------------------- (Exists(p).m <= p, n <= p)
  |||         G |- (x : S') -> T : Type(p)
  |||
  ||| Note that T is in (G;forall x:S'), but even so, (x : S') -> T is
  ||| in G The idea being if you can create a context from G that has
  ||| the additional "forall x:S'" in it and it implies that T exists,
  ||| then you can say that "(x : S') -> T" aka "forall x:S'.T" is implied
  ||| in G
  -- TODO 2 this only represents that (x : S') -> T is created, it doesn't specify
  --  the type as Type(p).. should we specify type in typeForExp??? seems so
  Pi : { n : Nat }
    -> (g : ANTContext)
    -> (S' : ANTExp g)
    -> (prf : typeForExp S' = (mkTypeN g n))
    -> (T : ANTExp (AddBinding g (PiBinding S' prf)))
    -> ANTExp g

  |||     G;\x:S' |- e : T   G |- (x : S') -> T : Type(n)
  ||| Lam ---------------------------------------------
  |||     G |- \x:S'.e : (x : S') -> T
  |||
  ||| Note, not in rule, but implied (S' : Type(n))... must be because
  ||| that's the only way to create G;\x:S', see Binding
  |||
  ||| Given a context, an arg type within that context, and an expression
  ||| that uses that var, returns a Lam.
  Lam : (g : ANTContext {n=i})
    -> (S' : ANTExp g)
    -> (prf : typeForExp S' = (mkTypeN g i)) -- necessary because LamBinding needs it
    -> (T : ANTExp g)
    -> (e : ANTExp (AddBinding g (LamBinding S' prf)))
    -> alphaEq (typeForExp e) (ChildContextImpliesSame g (LamBinding S' prf) T)
    -> ANTExp g

alphaEq (ChildContextImpliesSame parent b x) (ChildContextImpliesSame parent b y) = alphaEq x y
alphaEq (ChildContextImpliesSame parent b x) y@(TypeN (AddBinding parent b) n) = alphaEq x y
alphaEq (ChildContextImpliesSame parent b x) (Var (AddBinding parent b) n2) = Void --TODO this is wrong, because if child is a var, then it could be referencing the same
alphaEq (ChildContextImpliesSame parent b x) (Pi (AddBinding parent b) S' prf T) = Void
alphaEq (ChildContextImpliesSame parent b x) (Lam (AddBinding parent b) S' prf T e y) = Void
alphaEq x@(TypeN g n) y = x = y
alphaEq x@(Var g n2) y = x = y --TODO 2 this is wrong, because we have to take into account a parent context referencing same var as a child, ChildContextImpliesSame
alphaEq x@(Pi g S' prf T) y = x = y
alphaEq x@(Lam g S' prf T e x) y = x = y

mkTypeN g k = TypeN g k

{-

-- lemmaVarStillExists : (g : ANTContext) -> (e : ANTExp g)
--                     -> (e2 : ANTExp (AddVar g binder

lemmaLamTypeOfTypeIsTypeN : (n : Nat) -> (argType : ANTExp g) -> (i : Nat)
                    -> typeForExp argType = mkTypeN g i

lemmaPiTypeOfTypeIsTypeN : (n : Nat) -> (argType : ANTExp g) -> (i : Nat)
  -> typeForExp argType = mkTypeN g i

typeForExp (TypeN g n) = TypeN g (S n)
--typeForExp (Lam g argType exp) = ?typeForExp_rhs_2
typeForExp (Pi g S' prf T) = TypeN g ?chooseNForPi
  where
    chooseNForPi : {g : ANTContext} -> ANTExp g -> ANTExp g -> Nat
    chooseNForPi x y = ?chooseNForPi_rhs

{-
||| All contexts that are definable using this structure are valid.
|||
||| They can have variables added into them.  Variables come in 3
||| times, Lambda, Forall, and Let
|||
||| TODO 3 - Not sure why we need seperate types, idris impl decl says
||| "We record the binding ||| form in the context, as well as the
||| type, because type checking relies on evaluation. In particular,
||| let bound names may reduce."
--TODO 2.5 do we need "n"?
data ANTContext :  {n : Nat} -> Type where
  |||
  |||  --------
  |||  |- valid
  Empty : ANTContext {n}

  |||  G |- S' : Type(i)
  |||  ------------------
  |||  G;\x:S' |- valid
  |||
  |||  G |- S' : Type(i)
  |||  ------------------
  |||  G;forall x:S' |- valid
  |||
  ||| Adds a variable into the context. Note this is not the same
  ||| thing as creating a Lam Expression. It is rather the resulting
  ||| context to be used *within* the body of a lam expression that
  ||| has been created
  |||
  ||| See ANTExp.Lam to create a Lam, etc.
  AddVar : {i : Nat} -> {n : Nat} -> (ctx : ANTContext {n=n})
    -> (binder : Binder)
    -> (S' : ANTExp ctx)
    -> (typeForExp S' = (mkTypeN ctx i))
    -> ANTContext {n=n} -- HACK {n=S n}

    |||  G |- S : Type(i)
  |||  ------------------
  |||  G;forall x:S |- valid
  AddForallVar : {S : Expr} -> {i : Nat} -> (ctx : ANTContext)
    -> ImpliesExpr ctx (TypedExp S (TypeN i))
    -> ANTContext {S n}

  |||  G |- S : Type(i)   G |- s : S
  |||  --------------------------------
  |||  G;let x => s : S |- valid
  AddForallVar : {s : Expr} -> {S : Expr} -> {i : Nat} -> (ctx : ANTContext)
    -> ImpliesExpr ctx (TypedExp S (TypeN i))
    -> ImpliesExpr ctx (TypedExp s S)
    -> ANTContext {S n}

data ImpliesExpr : ANTContext -> TypedExp -> Type

||| Context
||| @n total number of vars
data ANTContext : {n : Nat} -> Type
data Expr : ANTContext -> Type
data ANTTypedExp : {ctx : ANTContext} -> (exp : Expr ctx) -> (typ : Expr ctx) -> Type where

||| Modeled from https://eb.host.cs.st-andrews.ac.uk/drafts/impldtp.pdf page 10
data ANTContext : {n : Nat} -> Type where
  |||
  |||  --------
  |||  |- valid
  Empty : ANTContext {n=0}

  |||  G |- S : Type(i)
  |||  ------------------
  |||  G;\x:S |- valid
  AddVar : (ctx : ANTContext {n}) -> Expr ctx -> ANTContext {n=(S n)}

getExprLemma1 : ANTContext -> Expr ctx -> Expr (AddVar ctx unrelatedVar)

||| TODO 2 getExpr doesn't prove it's getting the right expression
||| it could return anything. We need a view
getExpr : {n : Nat} -> (ctx : ANTContext {n}) -> Fin n -> ANTTypedExp ctx

betaEq : Expr ctx -> Expr ctx -> Type
betaEq = ?x

-- I Int | BI Integer | Fl Double | Ch Char | Str String

||| This represents when a context implies something. It is laid out
||| as the basic rules of the type theory system
||| Modeled from https://eb.host.cs.st-andrews.ac.uk/drafts/impldtp.pdf page 11
data Expr : ANTContext -> Type where
  |||  G |- valid
  |||  ------------
  |||  G |- Int : Type(0)
  ||| Part 1: the type "Int" can be implied from any context
  IntT : {ctx : ANTContext} -> Expr ctx

  |||  G |- valid
  |||  ------------
  |||  G |- Type(n) : Type(n+1)
  ||| Part 1: Every context implies Type(n) exists
  ||| Part 2 of this, that TypeN has a Type(n+1) is in data ANTType
  TypeN : (n : Nat) -> (g : ANTContext) -> Expr g

  |||  G |- valid
  |||  ------------
  |||  G |- i : Int
  IntC : {g : ANTContext} -> (i : Int) -> Expr g

  |||     G |- f : (x : S) -> T   G |- s : S
  ||| App ----------------------------------
  |||     G |- f s : T[s/x]
  App : (ctx : ANTContext {n})
    -> Ex
    -> (sInd : Fin n)
    -> betaEq (getExpr ctx fInd) (getExpr ctx sInd)
    -> Expr ctx
  |||     G;\x:S |- e : T   G |- (x : S) -> T : Type(n)
  ||| Lam ---------------------------------------------
  |||     G |- \x:S.e : (x : S) -> T
  ||| Given a context, an arg type within that context, and an expression
  ||| that uses that var, returns a Lam (variable name not specified
  ||| since we are using DeBrujin indexes)
  Lam : (ctx : ANTContext) -> (argType : Expr ctx)
    -> Expr (AddVar ctx argType) -> Expr ctx

||| This is an expression with an associated type.
|||
||| Note that the type is just a plain expression, even though, every
||| expression must have a type. This is because we can't have a typed
||| expression refer to itself in it's declaration, or it becomes an
||| infinite loop.
data ANTTypedExp : {ctx : ANTContext} -> (exp : Expr ctx) -> (typ : Expr ctx) -> Type where
  |||  G |- valid
  |||  ------------
  |||  G |- Type(n) : Type(n+1)
  ||| Part 2 TypeN has a Type(n+1) is in data ANTType
  TypeSNofN : (n : Nat) -> (g : ANTContext) -> ANTTypedExp (TypeN n g) (TypeN (S n) g)

  |||  G |- valid
  |||  ------------
  |||  G |- Int : Type(0)
  ||| Part 2 The type of Int is Type(0)
  Type0OfIntT : (g : ANTContext) -> ANTTypedExp IntT (TypeN 0 g)

  |||  G |- valid
  |||  ------------
  |||  G |- Int : Type(0)
  ||| Part 2 The type of IntC is IntT
  IntTOfInt : (i : Int) -> (g : ANTContext) -> ANTTypedExp (IntC i) IntT

getExprLemma1 x y = ?getExprLemma1_rhs

getExpr {n = Z} Empty FZ impossible
getExpr {n = Z} Empty (FS _) impossible
getExpr {n = (S k)} (AddVar ctx val) FZ = getExprLemma1 ctx val
getExpr {n = (S k)} (AddVar ctx val) (FS x) = getExprLemma1 ctx (getExpr ctx x)
-}

{-

||| Constants, c ::= Type i  (type universes)
|||                | i (integer literal)
|||                | str (string literal)
data ANTConst : Type where
  CType : Nat -> ANTConst
  CInt : Int -> ANTConst
  CStr : String -> ANTConst

||| Binders, b ::= \x : t (abstraction)
|||              | let x => t : t (let binding)
|||              | forall x : t (function space)
data ANTBinder : Type where
  BAbs : {n : Nat} -> ANTBinder
  BLet : {n : Nat} -> ANTBinder
  BForall : {n : Nat} -> ANTBinder

||| Terms, t ::= c (constant)
|||            | x (variable)
|||            | b. t (binding)
|||            | t t (application)
|||            | T (type constructor)
|||            | D (data constructor)
data ANTTerm : Type where
  TConst : ANTConst -> ANTTerm
  ||| each var has a name that must be unique
  TVar : String -> ANTTerm
  TBinding : ANTBinder -> ANTTerm
  TApp : ANTTerm -> ANTTerm -> ANTTerm
  TTypeCons : ANTTerm -- TODO 2 how to represent this?
  TDataCons : ANTTerm -- TODO 2 how to represent this?

data ContextualExpr : ANTTerm -> Type where
  TConst :

data ANTContext :  {n : Nat} -> Type where
  |||
  |||  --------
  |||  |- valid
  Empty : ANTContext {n}

  |||  G |- S : Type(i)
  |||  ------------------
  |||  G;\x:S |- valid
  AddLambdaVar : (n : Nat) -> (i : Nat) -> (varName : String)
    -> (ctx : ANTContext {n})
    -> (S : ContextualExpr ctx (TypeN i))
    -> ANTContext {n=S n}

-}
-}


import Data.Vect

f1 : (n : Nat) -> Vect n Nat -> Vect (S n) Nat
f1 a b = a :: b

f2 : (n : Nat) -> case n of
  k => Vect k Nat -> Vect (S k) Nat
f2 a b = a :: b

f3 : (n : Nat) -> case n of
  Z => Vect Z Nat -> Vect (S Z) Nat
  (S k) => Vect (S k) Nat -> Vect (S (S k)) Nat
f3 Z b = a :: b
f3 (S a) b = a :: b

f4 : (n : (Nat, Nat)) -> case n of
  (x, y) => Vect x Nat -> Vect (S x) Nat
f4 (_, a) b = a :: b


import Data.Vect

someVect : (n ** Vect n Int)
-- someVect = (_ ** [])

someVectLen : Nat
someVectLen = someVect.fst


module BatchedQueue

import Queue

%default total
%access private

export
data BatchedQueue a = BQ (List a) (List a)

check : List a -> List a -> BatchedQueue a
check [] r = BQ (reverse r) []
check f  r = BQ f           r

export
Queue BatchedQueue where
  empty = BQ [] []
  isEmpty (BQ f r) = isNil f

  snoc (BQ f r) x = check f (x :: r)

  head (BQ []       _) = idris_crash "empty queue"
  head (BQ (x :: f) r) = x

  tail (BQ []       _) = idris_crash "empty queue"
  tail (BQ (x :: f) r) = check f r


module Compo2

import Incrementer
import Twicer
import Halfer

%default total

-- Realized (incrementer . twicer . halfer).
rlz_compo2_attrs : RealizedAttributes
rlz_compo2_attrs = MkRealizedAttributes (MkCosts 600 60 6) 0.8
-- The following does not work because 601 ≠ 300+200+100
-- rlz_compo2_attrs = MkRealizedAttributes (MkCosts 601 60 6) 0.8
rlz_compo2 : RealizedFunction (Int -> Int) Compo2.rlz_compo2_attrs
rlz_compo2 = (compose rlz_incrementer (compose rlz_twicer rlz_halfer))


module Data.Crypto.Hash

import Data.Bits
import Data.Vect

%default total
%access public export

-- TODO: Add `maxMessageLength : Maybe Nat`. This would be `Nothing` for MD5 and
--      `Just (expt 2 64)` for the shorter SHS algos. And it should affect the
--       types of `initialize` and `hashMessage`.
interface Hash h (blockLength : Nat) (outputLength : Nat) | h where
  initialize : h -> Vect m (Bits n) -> List (Bits blockLength)
  initialContext : h -> h
  updateContext : h -> Bits blockLength -> h
  finalize : h -> Bits outputLength

hashMessage : Hash h b outputLength => h -> Vect m (Bits n) -> Bits outputLength
hashMessage hash message =
  finalize (foldl updateContext (initialContext hash) (initialize hash message))


-- This tests checks, whether toplevel constants are
-- properly memoized. If they are not, this test
-- will perform 10^20 additions and will therefore not
-- finish in reasonable time.
n0 : Nat
n0 = 1

n1 : Nat
n1 = n0 + n0 + n0 + n0 + n0 + n0 + n0 + n0 + n0 + n0

n2 : Nat
n2 = n1 + n1 + n1 + n1 + n1 + n1 + n1 + n1 + n1 + n1

n3 : Nat
n3 = n2 + n2 + n2 + n2 + n2 + n2 + n2 + n2 + n2 + n2

n4 : Nat
n4 = n3 + n3 + n3 + n3 + n3 + n3 + n3 + n3 + n3 + n3

n5 : Nat
n5 = n4 + n4 + n4 + n4 + n4 + n4 + n4 + n4 + n4 + n4

n6 : Nat
n6 = n5 + n5 + n5 + n5 + n5 + n5 + n5 + n5 + n5 + n5

n7 : Nat
n7 = n6 + n6 + n6 + n6 + n6 + n6 + n6 + n6 + n6 + n6

n8 : Nat
n8 = n7 + n7 + n7 + n7 + n7 + n7 + n7 + n7 + n7 + n7

n9 : Nat
n9 = n8 + n8 + n8 + n8 + n8 + n8 + n8 + n8 + n8 + n8

n10 : Nat
n10 = n9 + n9 + n9 + n9 + n9 + n9 + n9 + n9 + n9 + n9

n11 : Nat
n11 = n10 + n10 + n10 + n10 + n10 + n10 + n10 + n10 + n10 + n10

n12 : Nat
n12 = n11 + n11 + n11 + n11 + n11 + n11 + n11 + n11 + n11 + n11

n13 : Nat
n13 = n12 + n12 + n12 + n12 + n12 + n12 + n12 + n12 + n12 + n12

n14 : Nat
n14 = n13 + n13 + n13 + n13 + n13 + n13 + n13 + n13 + n13 + n13

n15 : Nat
n15 = n14 + n14 + n14 + n14 + n14 + n14 + n14 + n14 + n14 + n14

n16 : Nat
n16 = n15 + n15 + n15 + n15 + n15 + n15 + n15 + n15 + n15 + n15

n17 : Nat
n17 = n16 + n16 + n16 + n16 + n16 + n16 + n16 + n16 + n16 + n16

n18 : Nat
n18 = n17 + n17 + n17 + n17 + n17 + n17 + n17 + n17 + n17 + n17

n19 : Nat
n19 = n18 + n18 + n18 + n18 + n18 + n18 + n18 + n18 + n18 + n18

n20 : Nat
n20 = n19 + n19 + n19 + n19 + n19 + n19 + n19 + n19 + n19 + n19

main : IO ()
main = do printLn n20


module Implementation

import Data.String

data OneTwoThree a
  = One a
  | Two a a
  | Three a a a

[OTT] Functor OneTwoThree where
  map f = \case
    One x => One (f x)
    Two x y => Two (f x) (f y)
    Three x y z => Three (f x) (f y) (f z)

Show a => Show (OneTwoThree a) where
  show (One x) = "One " ++ show x
  show (Two x y) = unwords ["Two", show x, show y]
  show (Three x y z) = unwords ["Three", show x, show y, show z]

Eq a => Eq (OneTwoThree a) where
  One a == One x = a == x
  Two a b == Two x y = a == x && b == y
  Three a b c == Three x y z = a == x && b == y && c == z
  _ == _ = False


ts1 : Applicative m => m a -> m b -> m (a, a, b)
ts1 as bs = [| (,,) as as bs |]

ts2 : Applicative m => m a -> m b -> m (a, a, b)
ts2 as bs = [| (as, as, bs) |]


import Data.Vect

PIN : Type
PIN = Vect 4 Char

data ATMState = Ready | CardInserted | Session

data PINCheck = CorrectPIN | IncorrectPIN

data HasCard : ATMState -> Type where
    HasCI : HasCard CardInserted
    HasSession : HasCard Session

data ATMCmd : (ty : Type) -> ATMState -> (ty -> ATMState) -> Type where
    InsertCard : ATMCmd () Ready (const CardInserted)
    EjectCard : {auto prf : HasCard state} -> ATMCmd () state (const Ready)
    GetPIN : ATMCmd PIN CardInserted (const CardInserted)

    CheckPIN : PIN -> ATMCmd PINCheck CardInserted
                        (\check =>
                            case check of
                                CorrectPIN => Session
                                IncorrectPIN => CardInserted)
    GetAmount : ATMCmd Nat state (const state)

    Dispense : (amount : Nat) -> ATMCmd () Session (const Session)

    Message : String -> ATMCmd () state (const state)
    Pure : (res : ty) -> ATMCmd ty (stateFn res) stateFn
    (>>=) : ATMCmd a state1 state2Fn ->
            ((res : a) -> ATMCmd b (state2Fn res) state3Fn) ->
            ATMCmd b state1 state3Fn

atm : ATMCmd () Ready (const Ready)
atm =
    do
        InsertCard
        pin <- GetPIN
        cash <- GetAmount
        pinOK <- CheckPIN pin
        case pinOK of
            CorrectPIN =>
                do
                    Dispense cash
                    EjectCard
                    Message "Please remove your card and cash"
            IncorrectPIN =>
                do
                    Message "Incorrect PIN"
                    EjectCard

-- badATM : ATMCmd () state (const Ready)
-- badATM = EjectCard

testPIN : PIN
testPIN = ['1', '2', '3', '4']

readVect : (n : Nat) -> IO (Vect n Char)
readVect Z =
    do
        discard <- getLine
        pure []
readVect (S k) =
    do
        ch <- getChar
        chs <- readVect k
        pure (ch :: chs)

runATM : ATMCmd res inState outStateFn -> IO res
runATM InsertCard =
    do
        putStrLn "Please insert your card (press enter)"
        x <- getLine
        pure ()
runATM EjectCard  = putStrLn "Card ejected"
runATM GetPIN =
    do
        putStr "Enter PIN: "
        readVect 4
runATM (CheckPIN pin) =
    if pin == testPIN
        then pure CorrectPIN
        else pure IncorrectPIN
runATM GetAmount =
    do
        putStr "How much would you like? "
        x <- getLine
        pure (cast x)
runATM (Dispense amount) = putStrLn ("Here is " ++ show amount)
runATM (Message msg) = putStrLn msg
runATM (Pure res) = pure res
runATM (x >>= f) =
    do
        x' <- runATM x
        runATM (f x')


module Data.Void

export
absurdity : Uninhabited t => (0 _ : t) -> s
absurdity x = void (uninhabited x)

export
contradiction : Uninhabited t => (0 _ : x -> t) -> (x -> s)
contradiction since x = absurdity (since x)


-- Testing that 'with' works under parameters that are implicits
parameters {0 A : Type} (pred : A -> Bool)
  foo : A -> Bool
  foo x = case pred x of
    True  => False
    False => True

  bar : (x : A) -> not (pred x) = foo x
  bar  a with (pred a)
   bar a | True  = Refl
   bar a | False = Refl


module Main
-- Run a single test
-- > make test only=test013
import Cairo

example : Felt -> Cairo Felt
example n = dict 0 (\d =>
  let d1 = dwrite d 1 2
      d2 = dwrite d1 2 n
      d3 = dwrite d2 3 4
  in dread d3 2)

{-
Error: While processing right hand side of non_example. Trying to use linear name inner in non-linear context.

non_example : Felt -> Felt
non_example n =
  dict 0 (\outer =>
    let inner' = dict 1 (\inner => (outer, inner))
     in (inner', n)
  )
-}

pureDictComp : (1 d : LinDict) -> (LinDict, Felt)
pureDictComp d =
  let d1 = dwrite d 1 2
      d2 = dwrite d1 2 3
      d3 = dwrite d2 3 4
  in dread d3 5

%noinline
main : Cairo ()
main = do
    result1 <- example 42
    output result1
    result2 <- dict 8 pureDictComp
    output result2 -- returns default 8
    -- output $ non_example 42


module Algebra.Solver.Ring.SolvableRing

import Algebra.Ring

%default total

||| When normalizing arithmetic expressions, we must
||| make sure that factors that evaluate to zero must
||| be removed from the sum of products.
|||
||| For instance, the following example only works,
||| if the term `0 * x * y` gets removed before comparing
||| the normalized sums:
|||
||| ```idris example
||| 0 binom3 : {x,y : Bits8} -> (x + y) * (x - y) === x * x - y * y
||| binom3 = solve [x,y] ((x .+. y) * (x .-. y)) (x .*. x - y .*. y)
||| ```
|||
||| Because we cannot directly use a (primitive) pattern match
||| without having a concrete type, we need this interface.
||| (We *could* use `DecEq`, but this is not publicly exported
||| for the primitives; probably for good reasons since it is
||| implemented using `believe_me`).
public export
interface Ring a => SolvableRing a where

  ||| Checks if a value is propositionally equal to zero.
  isZero : (v : a) -> Maybe (v === 0)

public export
SolvableRing Bits8 where
  isZero 0 = Just Refl
  isZero _ = Nothing

public export
SolvableRing Bits16 where
  isZero 0 = Just Refl
  isZero _ = Nothing

public export
SolvableRing Bits32 where
  isZero 0 = Just Refl
  isZero _ = Nothing

public export
SolvableRing Bits64 where
  isZero 0 = Just Refl
  isZero _ = Nothing

public export
SolvableRing Int8 where
  isZero 0 = Just Refl
  isZero _ = Nothing

public export
SolvableRing Int16 where
  isZero 0 = Just Refl
  isZero _ = Nothing

public export
SolvableRing Int32 where
  isZero 0 = Just Refl
  isZero _ = Nothing

public export
SolvableRing Int64 where
  isZero 0 = Just Refl
  isZero _ = Nothing

public export
SolvableRing Int where
  isZero 0 = Just Refl
  isZero _ = Nothing

public export
SolvableRing Integer where
  isZero 0 = Just Refl
  isZero _ = Nothing


module Libraries.Data.Graph

import Libraries.Data.SortedMap
import Libraries.Data.SortedSet

import Data.List1

-- Mechanically transcribed from
-- https://en.wikipedia.org/wiki/Tarjan%27s_strongly_connected_components_algorithm#The_algorithm_in_pseudocode
private
record TarjanVertex where
  constructor TV
  index   : Int
  lowlink : Int
  inStack : Bool

private
record TarjanState cuid where
  constructor TS
  vertices           : SortedMap cuid TarjanVertex
  stack              : List cuid
  nextIndex          : Int
  components         : List (List1 cuid)
  impossibleHappened : Bool  -- we should get at least some indication of broken assumptions

initial : Ord cuid => TarjanState cuid
initial = TS empty [] 0 [] False

||| Find strongly connected components in the given graph.
|||
||| Input: map from vertex X to all vertices Y such that there is edge X->Y
||| Output: list of strongly connected components, ordered by output degree descending
export
tarjan : Ord cuid => SortedMap cuid (SortedSet cuid) -> List (List1 cuid)
tarjan {cuid} deps = loop initial (SortedMap.keys deps)
  where
    strongConnect : TarjanState cuid -> cuid -> TarjanState cuid
    strongConnect ts v =
        let ts'' = case SortedMap.lookup v deps of
              Nothing => ts'  -- no edges
              Just edgeSet => loop ts' (SortedSet.toList edgeSet)
          in case SortedMap.lookup v ts''.vertices of
              Nothing => { impossibleHappened := True } ts''
              Just vtv =>
                if vtv.index == vtv.lowlink
                  then createComponent ts'' v []
                  else ts''
      where
        createComponent : TarjanState cuid -> cuid -> List cuid -> TarjanState cuid
        createComponent ts v acc =
          case ts.stack of
            [] => { impossibleHappened := True } ts
            w :: ws =>
              let ts' : TarjanState cuid = {
                      vertices $= SortedMap.adjust w { inStack := False },
                      stack := ws
                    } ts
                in if w == v
                  then { components $= ((v ::: acc) ::) } ts'  -- that's it
                  else createComponent ts' v (w :: acc)

        loop : TarjanState cuid -> List cuid -> TarjanState cuid
        loop ts [] = ts
        loop ts (w :: ws) =
          loop (
            case SortedMap.lookup w ts.vertices of
              Nothing => let ts' = strongConnect ts w in
                case SortedMap.lookup w ts'.vertices of
                  Nothing => { impossibleHappened := True } ts'
                  Just wtv => { vertices $= SortedMap.adjust v { lowlink $= min wtv.lowlink } } ts'

              Just wtv => case wtv.inStack of
                False => ts  -- nothing to do
                True => { vertices $= SortedMap.adjust v { lowlink $= min wtv.index } } ts
          ) ws

        ts' : TarjanState cuid
        ts' = {
            vertices  $= SortedMap.insert v (TV ts.nextIndex ts.nextIndex True),
            stack     $= (v ::),
            nextIndex $= (1+)
          } ts

    loop : TarjanState cuid -> List cuid -> List (List1 cuid)
    loop ts [] =
      if ts.impossibleHappened
        then []
        else ts.components
    loop ts (v :: vs) =
      case SortedMap.lookup v ts.vertices of
        Just _ => loop ts vs  -- done, skip
        Nothing => loop (strongConnect ts v) vs


import Data.List

data Vect : Nat -> Type -> Type where
     Nil : Vect Z a
     (::) : a -> Vect k a -> Vect (S k) a

length : Vect n a -> Nat
length [] = Z
length (x :: xs) = S (length xs)

wrong : Nat -> Nat
wrong x = length x


module Main
import Data.Strings

myCondition : Nat -> String
myCondition x = case x of
                    Z => "Zero"
                    _ => "Non-Zero"

main : IO ()
main = do  putStr "Enter a positive number: "
           str <- getLine
           let num = stringToNatOrZ str
           printLn $ myCondition num
--           case num of
--               Z => do printLn $ "0"
--               Z => do printLn $ "Your number is interesting but you should think bigger."
--               (<= 6) => printLn "You can get that on a roll of dice."
--               (> 10) => printLn "You have to have multiple rolls of dice to get that."
           printLn $ "Bye for now."


data RunIO : Type -> Type where
  Quit : a -> RunIO a
  Do : IO a -> (a -> Inf (RunIO b)) -> RunIO b

(>>=) : IO a -> (a -> Inf (RunIO b)) -> RunIO b
(>>=) = Do

greet : RunIO ()
greet = do putStrLn "Enter your name: "
           name <- getLine
           if name == ""
              then do putStrLn "Bye bye!"
                      Quit()
              else do putStrLn ("Hello" ++ name)
                      greet
data Fuel = Dry | More (Lazy Fuel)

forever : Fuel
forever = More forever

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

run : Fuel -> RunIO a -> IO (Maybe a)
run fuel (Quit value) = pure (Just value)
run Dry (Do y f) = pure Nothing
run (More fuel) (Do c f) = do res <- c
                              run fuel (f res)

partial
main : IO ()
main = do run forever greet
          pure ()


module Main

import Data.Fin

%builtin Natural Nat
%builtin Natural Fin

%builtin NaturalToInteger Data.Fin.finToInteger

main : IO ()
main = putStrLn $ show $ finToInteger $ FS $ FZ {k=34}


module Eval

import Effects
import Effect.Exception
import Effect.State
import Effect.StdIO

import Prelude.List as L
import Prelude.Bool as B

import Parser
import LispVal
import Utils

export
Prim : Type
Prim = List (String, LispVal)

Unary : Type
Unary = LispVal -> Eval LispVal

Binary : Type
Binary = LispVal -> LispVal -> Eval LispVal

binop : Binary -> List LispVal -> Eval LispVal
binop op args = case args of
                     [x, y] => op x y
                     _ => raise $ NumArgs 2 args

numOp : (Integer -> Integer -> Integer) -> LispVal -> LispVal -> Eval LispVal
numOp op (Number x) (Number y) = pure $ Number $ op x  y
numOp op (Number x) y          = raise $ TypeMismatch "Number" y
numOp op x          _          = raise $ TypeMismatch "Number" x

numBoolBinop : (Integer -> Integer -> B.Bool) -> LispVal -> LispVal -> Eval LispVal
numBoolBinop op (Number x) (Number y) = pure $ Bool $ op x  y
numBoolBinop op (Number x) y          = raise $ TypeMismatch "bool" y
numBoolBinop op x          _          = raise $ TypeMismatch "bool" x

-- todo: more ops
export
primEnv : Prim
primEnv = [ ("+", Fun $ MkFun $ binop $ numOp (+))
            , ("-", Fun $ MkFun $ binop $ numOp (-))
            , ("*", Fun $ MkFun $ binop $ numOp (*))
            , ("/", Fun $ MkFun $ binop $ numOp div)
            , ("mod", Fun $ MkFun $ binop $ numOp mod)
            , ("quotient", Fun $ MkFun $ binop $ numOp divBigInt)
            , ("remainder", Fun $ MkFun $ binop $ numOp modBigInt)
            , ("=", Fun $ MkFun $ binop $ numBoolBinop (==))
            , ("<", Fun $ MkFun $ binop $ numBoolBinop (<))
            , (">", Fun $ MkFun $ binop $ numBoolBinop (>))
            , ("/=", Fun $ MkFun $ binop $ numBoolBinop (/=))
            , (">=", Fun $ MkFun $ binop $ numBoolBinop (>=))
            , ("<=", Fun $ MkFun $ binop $ numBoolBinop (<=))]

mutate : String -> LispVal -> (String, LispVal) -> (String, LispVal)
mutate atom exp (a, b) = if a == atom
                         then (a, exp)
                         else (a, b)

addToEnv : String -> LispVal -> EnvCtx -> EnvCtx
addToEnv n v ls = (n, v) :: ls

mutual
  eval : LispVal -> Eval LispVal
  eval val@(Number n)  = pure val
  eval val@(Str s)     = pure val
  eval val@(Bool b)    = pure val
  eval (List Nil)      = pure Nil
  eval Nil             = pure Nil
  eval val@(Atom atom) = getVar val
  eval (List [Atom "quote", val]) = pure val
  eval (List [Atom "if", pred, conseq, alt]) = case !(eval pred) of
                                                    Bool False => eval alt
                                                    _  => eval conseq
  eval (List [Atom "def", (Atom val), exp]) = defineVar (Atom val) exp
  eval (List [Atom "define", (Atom val), exp]) = defineVar (Atom val) exp
  eval (List [Atom "lambda", params, exp]) = do p <- evalToList params
                                                pure $ Lambda (MkFun (\args => (evalArgsExpEnv args p exp))) !get
  eval (List [(Atom fn), a, b]) =
    do
      func <- getVar $ Atom fn
      case func of
           (Fun (MkFun f)) => f [!(eval a), !(eval b)]
           (Lambda (MkFun f) boundEnv) => do put boundEnv
                                             f [!(eval a), !(eval b)]
           _ => raise $ NotFunction "Unrecognized primitive function" $ show func
  eval somethingElse = raise $ Default $ "unmatched case " ++ show somethingElse

  evalArgsExpEnv : List LispVal -> List LispVal -> LispVal -> Eval LispVal
  evalArgsExpEnv args params exp =
    do bindVars $ zipWith MkPair params args
       eval exp

  setLocal : String -> LispVal -> EnvCtx -> Eval LispVal
  setLocal atom exp env = do update (addToEnv atom exp)
                             eval exp

  setVar : LispVal -> LispVal -> Eval LispVal
  setVar n@(Atom atom) exp = do env <- get
                                case lookup atom env of
                                     Just x => setLocal atom exp env
                                     Nothing => raise $ UnboundVar "unbound variable" n
  setVar _  exp = raise $ LispErr "variables can only be assigned to atoms"

  defineVar : LispVal -> LispVal -> Eval LispVal
  defineVar (Atom atom) exp = setLocal atom exp !get
  defineVar _  exp = raise $ LispErr "can only bind to Atom type valaues"

  getVar : LispVal -> Eval LispVal
  getVar n@(Atom atom) = case lookup atom !get of
                              Nothing => raise $ UnboundVar "unbound variable" n
                              Just val => pure val
  getVar _             = raise $ LispErr "variables can only be assigned to atoms"

  evalToList : LispVal -> Eval (L.List LispVal)
  evalToList expr =
    do
      val <- eval expr
      case val of
           List x => pure x
           _      => raise $ Default "error evaluating into list"

  cons : L.List LispVal -> Eval LispVal
  cons [x, y@(List _)] =
    do
      v <- eval x
      v' <- evalToList y
      pure $ List $ v :: v'
  cons [c] =
    do
      _ <- eval c
      pure $ List [c]
  cons []  = pure $ List []

  -- traverse
  traverse' : L.List LispVal -> Eff (List LispVal) [STATE EnvCtx, EXCEPTION LispError]
  traverse' [x]       = pure [x]
  traverse' (x :: xs) = do x' <- eval x
                           pure $ x' :: !(traverse' xs)
  traverse' []        = raise $ Default "empty body"

  uncurryDef : (LispVal, LispVal) -> Eval LispVal
  uncurryDef = uncurry defineVar

  bindVars : L.List (LispVal, LispVal) -> Eval ()
  bindVars [] = pure ()
  bindVars (x :: xs) =
    do uncurryDef x
       bindVars xs

-- end mutual

runParse_ : String -> Either LispError LispVal
runParse_ = mapLeft (\_ => Default "parser error") . readExpr

testEnv : EnvCtx
testEnv = ("x", Number 42) :: primEnv

textToEval : String -> Eval LispVal
textToEval input =
  case runParse_ input of
       Right val => eval val
       Left err  => raise $ err

runApp : EnvCtx -> Eval b -> Eff (EnvCtx, b) [STATE EnvCtx, STDIO, EXCEPTION LispError]
runApp code action =
  do
    put code
    v <- action
    pure (!get, v)

-- fix me
export
evalExpr : EnvCtx -> String -> IO EnvCtx
evalExpr env expr =
  do
    case the (Either LispError LispVal) $ runInit (env :: () :: []) $ textToEval expr of
      Left err => do putStrLn $ show err
                     pure $ env
      Right val => do (e, v) <- run $ runApp env $ textToEval expr
                      putStrLn $ show v
                      pure $ e


f : (Nat -> Nat) -> Nat
f k = f \n => k (S n)

g : Nat -> Nat
g x = f ?a


module Control.Algebra.DiamondInstances

import Control.Algebra
import Classes.Verified -- definition of verified algebras other than modules

%default total

{-
Diamond instances
explicitly referenced for using in treating diamond inheritance problems
* VerifiedGroup a -> Semigroup a
* VerifiedRingWithUnity a -> Semigroup a
* VerifiedRingWithUnity a -> Ring a
-}

vgrpVerifiedMonoid : VerifiedGroup a -> VerifiedMonoid a
vgrpVerifiedMonoid a = %instance

vgrpGroup : VerifiedGroup a -> Group a
vgrpGroup a = %instance

vmonSemigrp : VerifiedMonoid a -> Semigroup a
vmonSemigrp a = %instance

grpSemigrp : Group a -> Semigroup a
grpSemigrp a = %instance

vgrpSemigroupByVMon : VerifiedGroup a -> Semigroup a
vgrpSemigroupByVMon = vmonSemigrp . vgrpVerifiedMonoid

vgrpSemigroupByGrp : VerifiedGroup a -> Semigroup a
vgrpSemigroupByGrp = grpSemigrp . vgrpGroup

vrSemigroupByVMon : VerifiedRing a -> Semigroup a
vrSemigroupByVMon a = vgrpSemigroupByVMon %instance

vrSemigroupByGrp : VerifiedRing a -> Semigroup a
vrSemigroupByGrp a = vgrpSemigroupByGrp %instance

vrwuSemigroupByVMon : VerifiedRingWithUnity a -> Semigroup a
vrwuSemigroupByVMon a = vgrpSemigroupByVMon %instance

vrwuSemigroupByGrp : VerifiedRingWithUnity a -> Semigroup a
vrwuSemigroupByGrp a = vgrpSemigroupByGrp %instance

vrwuVerifiedRing : VerifiedRingWithUnity a -> VerifiedRing a
vrwuVerifiedRing a = %instance

vrwuRingWithUnity : VerifiedRingWithUnity a -> RingWithUnity a
vrwuRingWithUnity a = %instance

vrRing : VerifiedRing a -> Ring a
vrRing a = %instance

rwuRing : RingWithUnity a -> Ring a
rwuRing a = %instance

vrwuRingByVR : VerifiedRingWithUnity a -> Ring a
vrwuRingByVR = vrRing . vrwuVerifiedRing

vrwuRingByRWU : VerifiedRingWithUnity a -> Ring a
vrwuRingByRWU = rwuRing . vrwuRingWithUnity


data Bar = MkBar
data Baz = MkBaz

data Vect : Nat -> Type -> Type where
     Nil : Vect Z a
     (::) : a -> Vect k a -> Vect (S k) a

desc : Type -> String
desc Int = "Int"
desc Nat = "Nat"
desc (Vect n a) = "Vector of " ++ show n ++ " " ++ desc a
desc Type = "Type"
desc _ = "Something else"

descNat : Type -> String
descNat t = "Function from Nat to " ++ desc t

descFn : (x : Type) -> String
descFn ((x : Nat) -> b) = descNat (b Z)
descFn (a -> b) = "Function on " ++ desc a
descFn x = desc x

main : IO ()
main = do printLn (descFn (Nat -> Nat))
          printLn (descFn ((x : Nat) -> Vect x Int))
          printLn (descFn (Type -> Int))


import Data.Vect
import Data.Vect.Elem

oneInVector : Elem 1 [1,2,3]
oneInVector = Here

maryInVector : Elem "Mary" ["Peter", "Paul", "Mary"]
maryInVector = There (There Here)

fourNotInVector : Elem 4 [1,2,3] -> Void
fourNotInVector (There (There (There Here))) impossible
fourNotInVector (There (There (There (There _)))) impossible

peteNotInVector : Elem "Pete" ["John", "Paul", "George", "Ringo"] -> Void
peteNotInVector (There (There (There (There Here)))) impossible
peteNotInVector (There (There (There (There (There _))))) impossible


module Main

data Free : (f : Type -> Type) -> (a : Type) -> Type where
  Pure : a -> Free f a
  Bind : f (Free f a) -> Free f a

Functor f => Functor (Free f) where
  map f m = assert_total $ case m of
    Pure x => Pure (f x)
    Bind x => Bind (map (map f) x)

Functor f => Applicative (Free f) where
  pure = Pure

  m <*> x = assert_total $ case m of
    Pure f => map f x
    Bind f => Bind (map (<*> x) f)

Functor f => Monad (Free f) where
  m >>= f = assert_total $ case m of
    Pure x => f x
    Bind x => Bind (map (>>= f) x)

liftFree : Functor f => f a -> Free f a
liftFree = assert_total $ Bind . map Pure

foldFree : (Monad m, Functor f) => ({ a : Type } -> f a -> m a) -> Free f b -> m b
foldFree f m = assert_total $ case m of
  Pure x => pure x
  Bind x => f x >>= foldFree f

data FileSystemF next
  = ReadFile (String -> next)

FileSystem : Type -> Type
FileSystem = Free FileSystemF

Functor FileSystemF where
  map f (ReadFile nextFn) = ReadFile (f . nextFn)

readFileF : FileSystem String
readFileF = liftFree $ ReadFile id

interpret2 : FileSystemF a -> IO a
interpret2 (ReadFile nextFn) = do
  contents <- pure "ola"
  pure (nextFn contents)

main : IO ()
main =
  do
    c <- foldFree interpret2 readFileF
    putStrLn' c


data Bool = True | False

data Li : (a : Type) -> Type where
  Ni : Li a
  Co : a -> Li a -> Li a

myprod : Li Type -> Type
myprod li = Int

t : Li Type -> Type
t li = Type

hej : (Li Type -> Type) -> Type
hej f = f (Co (Li Type) Ni)

-- data Cart : (a : Type) -> (b : Type) -> Type where
--   Mul : a -> b -> Cart a b

-- v : Cart Type Type
-- v = Mul Int Int

-- -- Prod : Li Type -> Cart a a
-- -- Prod (Co b (Co a nil)) = Mul a b
-- -- Prod : Li Type -> Type
-- -- Prod (Co a rest) = Mul a rest

-- -- data Top : Type where
-- --   qwer : Top

-- Prod : Li Type -> Type
-- Prod Ni = Type
-- Prod (Co q qs) = Mul q (Prod qs)

-- -- myid : (a : Type) -> a -> a
-- -- myid _ x = x

-- id2 : a -> a
-- id2 x = x

-- idid : {a : Type} -> a -> a
-- idid = id2

-- q : Type -> Type
-- q a = id2 (id2 a)

-- test : Type -> Type
-- test x = x

-- a : Type
-- a = test Int

-- b : Type
-- b = test Type