module SMTLib

import Data.Vect
import System

%access public export

data NumTyp = IntT | RealT

data TypeT : Type where
  BoolT : TypeT
  NumT : NumTyp -> TypeT
  BitVecT : Nat -> TypeT

Show TypeT where
  show BoolT = "Bool"
  show (NumT IntT) = "Int"
  show (NumT RealT) = "Real"
  show (BitVecT n) = "(_ BitVec " ++ show n ++ ")"

data Expr : TypeT -> Type where
  VarExpr : String -> (t : TypeT) -> Expr t
  BoolExpr : Bool -> Expr BoolT
  BvExpr : Int -> (n : Nat) -> Expr (BitVecT n)
  BvAddExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvSubExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvMulExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvUDivExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvURemExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvSDivExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvSModExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvShLExpr :  Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvLShRExpr :  Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvAShRExpr :  Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvNegExpr : Expr (BitVecT n) -> Expr (BitVecT n)
  BvAndExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvOrExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvXorExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
  BvNotExpr : Expr (BitVecT n) -> Expr (BitVecT n)
  BvULeExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
  BvULtExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
  BvUGeExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
  BvUGtExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
  BvSLeExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
  BvSLtExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
  BvSGeExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
  BvSGtExpr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
  IntExpr : Int -> Expr (NumT IntT)
  RealExpr : Double -> Expr (NumT RealT)
  AddExpr : Vect n (Expr (NumT a)) -> Expr (NumT a)
  MinusExpr : Vect n (Expr (NumT a)) -> Expr (NumT a)
  MulExpr : Vect n (Expr (NumT a)) -> Expr (NumT a)
  EqualExpr : Expr a -> Expr a -> Expr BoolT
  DistinctExpr : Vect n (Expr a) -> Expr BoolT
  LessExpr : Expr (NumT a) -> Expr (NumT a) -> Expr BoolT
  LessOrEqualExpr : Expr (NumT a) -> Expr (NumT a) -> Expr BoolT
  GreaterExpr : Expr (NumT a) -> Expr (NumT a) -> Expr BoolT
  GreaterOrEqualExpr : Expr (NumT a) -> Expr (NumT a) -> Expr BoolT
  AndExpr : Vect n (Expr BoolT) -> Expr BoolT
  OrExpr : Vect n (Expr BoolT) -> Expr BoolT
  NotExpr : Expr BoolT -> Expr BoolT
  ImpExpr : Expr BoolT -> Expr BoolT -> Expr BoolT
  IteExpr : Expr BoolT -> Expr a -> Expr a -> Expr a

bool : Bool -> Expr BoolT
bool x = BoolExpr x

bv : Int -> (n : Nat) -> Expr (BitVecT n)
bv x n = BvExpr x n

int : Int -> Expr (NumT IntT)
int x = IntExpr x

real : Double -> Expr (NumT RealT)
real x = RealExpr x

bvadd : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvadd l r = BvAddExpr l r

bvsub : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvsub l r = BvSubExpr l r

bvmul : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvmul l r = BvMulExpr l r

bvsdiv : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvsdiv l r = BvSDivExpr l r

bvsmod : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvsmod l r = BvSModExpr l r

bvudiv : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvudiv l r = BvUDivExpr l r

bvurem : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvurem l r = BvURemExpr l r

bvshl : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvshl l r = BvShLExpr l r

bvlshr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvlshr l r = BvLShRExpr l r

bvashr : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvashr l r = BvAShRExpr l r

bvneg : Expr (BitVecT n) -> Expr (BitVecT n)
bvneg x = BvNegExpr x

bvand : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvand l r = BvAndExpr l r

bvor : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvor l r = BvOrExpr l r

bvxor : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr (BitVecT n)
bvxor l r = BvXorExpr l r

bvnot : Expr (BitVecT n) -> Expr (BitVecT n)
bvnot x = BvNotExpr x

bvule : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
bvule l r = BvULeExpr l r

bvult : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
bvult l r = BvULtExpr l r

bvuge : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
bvuge l r = BvUGeExpr l r

bvugt : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
bvugt l r = BvUGtExpr l r

bvsle : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
bvsle l r = BvSLeExpr l r

bvslt : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
bvslt l r = BvSLtExpr l r

bvsge : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
bvsge l r = BvSGeExpr l r

bvsgt : Expr (BitVecT n) -> Expr (BitVecT n) -> Expr BoolT
bvsgt l r = BvSGtExpr l r

(+) : Expr (NumT a) -> Expr (NumT a) -> Expr (NumT a)
(+) l r = AddExpr [l, r]

(-) : Expr (NumT a) -> Expr (NumT a) -> Expr (NumT a)
(-) l r = MinusExpr [l, r]

add : Vect n (Expr (NumT a)) -> Expr (NumT a)
add xs = AddExpr xs

(*) : Expr (NumT a) -> Expr (NumT a) -> Expr (NumT a)
(*) l r = MulExpr [l, r]

mul : Vect n (Expr (NumT a)) -> Expr (NumT a)
mul xs = MulExpr xs

(==) : Expr a -> Expr a -> Expr BoolT
(==) l r = EqualExpr l r

distinct : Vect n (Expr a) -> Expr BoolT
distinct xs = DistinctExpr xs

(<) : Expr (NumT a) -> Expr (NumT a) -> Expr BoolT
(<) l r = LessExpr l r

(<=) : Expr (NumT a) -> Expr (NumT a) -> Expr BoolT
(<=) l r = LessOrEqualExpr l r

(>) : Expr (NumT a) -> Expr (NumT a) -> Expr BoolT
(>) l r = GreaterExpr l r

(>=) : Expr (NumT a) -> Expr (NumT a) -> Expr BoolT
(>=) l r = GreaterOrEqualExpr l r

(&&) : Expr BoolT -> Expr BoolT -> Expr BoolT
(&&) l r = AndExpr [l, r]

(||) : Expr BoolT -> Expr BoolT -> Expr BoolT
(||) l r = OrExpr [l, r]

and : Vect n (Expr BoolT) -> Expr BoolT
and xs = AndExpr xs

or : Vect n (Expr BoolT) -> Expr BoolT
or xs = OrExpr xs

not : Expr BoolT -> Expr BoolT
not x = NotExpr x

imp : Expr BoolT -> Expr BoolT -> Expr BoolT
imp l r = ImpExpr l r

ite' : Expr BoolT -> Expr BoolT -> Expr BoolT -> Expr BoolT
ite' p l r = and [imp p l, imp (not p) r]

ite : Expr BoolT -> Expr a -> Expr a -> Expr a
ite p l r = IteExpr p l r

data Cmd : Type -> Type where
  DeclareVarCmd : String -> (t : TypeT) -> Cmd (Expr t)
  DeclareVarsCmd : Traversable f => f String -> (t : TypeT) -> Cmd (f (Expr t))
  AssertCmd : Expr BoolT -> Cmd ()
  CheckSatCmd : Cmd ()
  GetModelCmd : Cmd ()
  SetOptionCmd : String -> Cmd ()
  SetLogicCmd : String -> Cmd ()

data Smt : Type -> Type where
  Pure : a -> Smt a
  Bind : Cmd a -> (a -> Smt b) -> Smt b

pure : a -> Smt a
pure x = Pure x

(>>=) : Smt a -> (a -> Smt b) -> Smt b
(>>=) (Pure x) f = f x
(>>=) (Bind cmd g) f = Bind cmd (\x => g x >>= f)

end : Smt ()
end = Pure ()

declareVar : String -> (t : TypeT) -> Smt (Expr t)
declareVar v t = Bind (DeclareVarCmd v t) pure

declareVars : Traversable f => f String -> (t : TypeT) -> Smt (f (Expr t))
declareVars vs t = Bind (DeclareVarsCmd vs t) pure

assert : Expr BoolT -> Smt ()
assert e = Bind (AssertCmd e) pure

checkSat : Smt ()
checkSat = Bind CheckSatCmd pure

getModel : Smt ()
getModel = Bind GetModelCmd pure

setOption : String -> Smt ()
setOption s = Bind (SetOptionCmd s) pure

setLogic : String -> Smt ()
setLogic s = Bind (SetLogicCmd s) pure

compileExpr : Expr t -> String
compileExpr (VarExpr x t) = x
compileExpr (BoolExpr x) = if x then "true" else "false"
compileExpr (BvExpr x n) = "(_ bv" ++ show x ++ " " ++ show n ++ ")"
compileExpr (IntExpr x) = show x
compileExpr (RealExpr x) = show x
compileExpr (BvAddExpr l r) = "(bvadd " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvMulExpr l r) = "(bvmul " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvSDivExpr l r) = "(bvsdiv " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvSModExpr l r) = "(bvsmod " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvUDivExpr l r) = "(bvudiv " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvURemExpr l r) = "(bvurem " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvShLExpr l r) = "(bvshl " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvLShRExpr l r) = "(bvlshr " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvAShRExpr l r) = "(bvashr " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvNegExpr x) = "(bvneg " ++ compileExpr x ++ ")"
compileExpr (BvAndExpr l r) = "(bvand " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvSubExpr l r) = "(bvsub " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvOrExpr l r) = "(bvor " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvXorExpr l r) = "(bvxor " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvNotExpr x) = "(bvnot " ++ compileExpr x ++ ")"
compileExpr (BvULeExpr l r) = "(bvule " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvULtExpr l r) = "(bvult " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvUGeExpr l r) = "(bvuge " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvUGtExpr l r) = "(bvugt " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvSLeExpr l r) = "(bvsle " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvSLtExpr l r) = "(bvslt " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvSGeExpr l r) = "(bvsge " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (BvSGtExpr l r) = "(bvsgt " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (AddExpr xs) = "(+ " ++ (unlines . toList . map compileExpr) xs ++ ")"
compileExpr (MinusExpr xs) = "(- " ++ (unlines . toList . map compileExpr) xs ++ ")"
compileExpr (MulExpr xs) = "(* " ++ (unlines . toList . map compileExpr) xs ++ ")"
compileExpr (EqualExpr l r) = "(= " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (DistinctExpr xs) = "(distinct " ++ (unlines . toList . map compileExpr) xs ++ ")"
compileExpr (LessExpr l r) = "(< " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (LessOrEqualExpr l r) = "(<= " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (GreaterExpr l r) = "(> " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (GreaterOrEqualExpr l r) = "(>= " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (AndExpr xs) = "(and " ++ (unlines . toList . map compileExpr) xs ++ ")"
compileExpr (OrExpr xs) = "(or " ++ (unlines . toList . map compileExpr) xs ++ ")"
compileExpr (NotExpr x) = "(not " ++ compileExpr x ++ ")"
compileExpr (ImpExpr l r) = "(=> " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"
compileExpr (IteExpr p l r) = "(if " ++ compileExpr p ++ " " ++ compileExpr l ++ " " ++ compileExpr r ++ ")"

compileCmd : Cmd a -> (a, String)
compileCmd (DeclareVarCmd x t) = (VarExpr x t, "(declare-const " ++ x ++ " " ++ show t ++ ")")
compileCmd (DeclareVarsCmd xs t) = (map (\x => VarExpr x t) xs,
                                    (unlines . toList . map (\x => "(declare-const " ++ x ++ " " ++ show t ++ ")")) xs)
compileCmd (AssertCmd e) = ((), "(assert " ++ compileExpr e ++ ")")
compileCmd CheckSatCmd = ((), "(check-sat)")
compileCmd GetModelCmd = ((), "(get-model)")
compileCmd (SetOptionCmd s) = ((), "(set-option " ++ s ++ ")")
compileCmd (SetLogicCmd s) = ((), "(set-logic " ++ s ++ ")")

compile : Smt () -> String
compile smt = unlines $ compile' smt
  where
    compile' : Smt () -> List String
    compile' (Pure ()) = [""]
    compile' (Bind cmd f) = let (a, s) = compileCmd cmd in
                           let s' = compile' $ f a in
                           s :: s'

example0 : Expr BoolT
example0 = (bool True) && (bool True)

example1 : Expr BoolT
example1 = (bv 1 8) == (bv 1 8)

example2 : Smt ()
example2 = checkSat

example3 : Smt ()
example3 = do x <- declareVar "x" BoolT
              y <- declareVar "y" BoolT
              assert $ x && y
              checkSat
              getModel
              end

example4 : Smt ()
example4 = do [x, y] <- declareVars {f = Vect 2} ["x", "y"] BoolT
              assert $ not (x && y) == (not x || not y)
              checkSat
              getModel
              end

exec : String -> String -> IO Int
exec input output = system $ "z3 -smt2 " ++ input ++ " > " ++ output

data Result = Sat | UnSat | Unknown

Show Result where
  show Sat = "sat"
  show UnSat = "unsat"
  show Unknown = "unknown"

Model : Type
Model = List (String, String)

parseResult : List String -> Maybe (Result, List String)
parseResult ("sat" :: "(model " :: xs) = Just (Sat, xs)
parseResult ("unsat" :: xs) = Just (UnSat, xs)
parseResult ("unknown" :: xs) = Just (Unknown, xs)
parseResult _ = Nothing

parseVar : List Char -> Maybe (List Char)
parseVar ('(' :: 'd' :: 'e' :: 'f' :: 'i' :: 'n' :: 'e' :: '-' :: 'f' :: 'u' :: 'n' :: ' ' :: xs) = parseVar' xs
  where
    parseVar' : List Char -> Maybe (List Char)
    parseVar' (' ' :: xs) = Just []
    parseVar' (x :: xs) = do xs <- parseVar' xs
                             Just (x :: xs)
    parseVar' _ = Nothing
parseVar _ = Nothing

parseValue' : List Char -> Maybe (List Char)
parseValue' [] = Just []
parseValue' (')' :: _) = Just []
parseValue' (' ' :: _) = Just []
parseValue' [_] = Nothing
parseValue' (x :: xs) = do xs <- parseValue' xs
                           Just (x :: xs)

parseValue : List Char -> Maybe (List Char)
parseValue ('(' :: '_' :: ' ' :: 'b' :: 'v' :: xs) = parseValue' xs
parseValue xs = parseValue' xs

parseModel : List String -> Maybe (Model, List String)
parseModel [")"] = Just ([], [])
parseModel (x :: y :: xs) = do (model, xs) <- parseModel xs
                               var <- parseVar (unpack (ltrim x))
                               value <- parseValue (unpack (ltrim y))
                               Just ((pack var, pack value) :: model, xs)
parseModel _ = Nothing

sat : Smt () -> IO (Maybe (Result, Model))
sat smt = do _ <- writeFile "input.smt2" $ compile smt
             putStrLn "z3 solving"
             _ <- exec "input.smt2" "output.smt2"
             r <- readFile "output.smt2"
             case r of
               Left err => do printLn err; pure Nothing
               Right str => let r = parseResult $ filter (\line => not $ line == "") $ lines str in
                            case r of
                              Nothing => do putStrLn "Error parsing result"; pure Nothing
                              Just (Sat, xs) => let r = parseModel xs in
                                                case r of
                                                  Nothing => do putStrLn "Error parsing model"; pure Nothing
                                                  Just (model, xs) => pure $ Just (Sat, model)
                              Just (UnSat, xs) => pure $ Just (UnSat, [])
                              Just (Unknown, xs) => pure $ Just (Unknown, [])

print : Smt () -> IO ()
print smt = putStrLn $ compile smt


f : (Int -> Bool) -> Int

il : Int
il = f \x => x > 0

lc : Int
lc = f $ \case 0 => True ; _ => False

ilc : Int
ilc = f \case 0 => True; _ => False


import Data.Vect

{-
Matrix type using type synonyms
 -}

Matrix : Nat -> Nat -> Type
Matrix i j = Vect i (Vect j Double)

testMatrix : Matrix 2 3
testMatrix = [[0, 0, 0], [0, 0, 0]]


module Data.Time.LocalTime.TimeOfDay

import Data.So
import Data.Maybe

import Data.Fixed
import Data.Rational
import Data.Time.Clock.DiffTime
import Data.Time.LocalTime.TimeZone
import Text.Format.Decimal

import Generics.Derive

%default total
%language ElabReflection

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

public export
record TimeOfDay where
  constructor MkTimeOfDay
  hour : Int
  min : Int
  sec : Fixed 12
%runElab derive "TimeOfDay" [Generic, Eq, Ord, DecEq]

public export
Show TimeOfDay where
  show x = let fmt = zeroPad 2
    in format' fmt x.hour ++ (format' fmt x.min) ++ (format' fmt x.sec)

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

||| Hour zero
export midnight : TimeOfDay
midnight = MkTimeOfDay 0 0 0

||| Hour twelve
export midday : TimeOfDay
midday = MkTimeOfDay 12 0 0

export makeTimeOfDayValid : Int -> Int -> Fixed 12 -> Maybe TimeOfDay
makeTimeOfDayValid h m s =
  toMaybe (h < 0 || h > 22 || m < 0 || m > 59 || s < 0 || s >= 61) $ MkTimeOfDay h m s

||| Convert a period of time into a count of days and a time of day since midnight.
||| The time of day will never have a leap second.
export timeToDaysAndTimeOfDay : DiffTime' isnominal -> (Integer, TimeOfDay)
timeToDaysAndTimeOfDay dt = let
  sixty = the (Fixed 12) 60
  m  = dt.seconds `div'` sixty
  h  = m `div` 60
  d  = h `div` 24
  in (d, MkTimeOfDay (cast $ h `mod` 24) (cast $ m `mod` 60) (dt.seconds `mod'` sixty))

||| Convert a count of days and a time of day since midnight into a period of time.
export daysAndTimeOfDayToTime : Integer -> TimeOfDay -> NominalDiffTime
daysAndTimeOfDayToTime d (MkTimeOfDay dh hm ms) =
  SecondsToDiffTime $ ms + fromInteger (cast hm * 60 + cast dh * 3600 + d * (24 * 3600))

||| Convert a time of day in UTC to a time of day in some timezone, together with a day adjustment.
export utcToLocalTimeOfDay : TimeZone -> TimeOfDay -> (Integer, TimeOfDay)
utcToLocalTimeOfDay zone (MkTimeOfDay h m s) = let
  m' = m + zone.minutes
  h' = h + (div m' 60)
  in (cast (div h' 24), MkTimeOfDay (mod h' 24) (mod m' 60) s)

||| Convert a time of day in some timezone to a time of day in UTC, together with a day adjustment.
export localToUTCTimeOfDay : TimeZone -> TimeOfDay -> (Integer, TimeOfDay)
localToUTCTimeOfDay zone = utcToLocalTimeOfDay (minutesToTimeZone (negate zone.minutes))

||| Get the time of day given a time since midnight.
||| Time more than 24h will be converted to leap-seconds.
export timeToTimeOfDay : DiffTime' isnominal -> TimeOfDay
timeToTimeOfDay dt =
  if dt.seconds >= nominalDay.seconds
     then MkTimeOfDay 23 59 $ 60 + (dt.seconds - nominalDay.seconds)
     else let
       m = dt.seconds `div'` 60
       in MkTimeOfDay (cast $ m `div` 60) (cast $ m `mod` 60) (dt.seconds `mod'` 60)

||| Same as 'timeToTimeOfDay'.
export pastMidnight : DiffTime -> TimeOfDay
pastMidnight = timeToTimeOfDay

||| Get the time since midnight for a given time of day.
export timeOfDayToTime : TimeOfDay -> DiffTime
timeOfDayToTime (MkTimeOfDay h m s) =
  SecondsToDiffTime $ s + fromInteger (cast m * 60 + cast h * 3600)

||| Same as 'timeOfDayToTime'.
export sinceMidnight : TimeOfDay -> DiffTime
sinceMidnight = timeOfDayToTime

||| Get the time of day given the fraction of a day since midnight.
export dayFractionToTimeOfDay : Rational -> Maybe TimeOfDay
dayFractionToTimeOfDay df =
  map (timeToTimeOfDay . the NominalDiffTime . SecondsToDiffTime) $ cast (df * 86400)

||| Get the fraction of a day since midnight given a time of day.
export timeOfDayToDayFraction : TimeOfDay -> Rational
timeOfDayToDayFraction tod = let
  MkFixed num = (timeOfDayToTime tod).seconds
  MkFixed den = nominalDay.seconds
  _ = the (So (den /= 0)) $ believe_me Oh
  in num %: den

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


||| How to replace things.
|||
||| Module    : Substitution.idr
||| Copyright : (c) Jan de Muijnck-Hughes
||| License   : see LICENSE
|||
module Toolkit.DeBruijn.Substitution

import Decidable.Equality

import Data.DPair

import Toolkit.Decidable.Informative

import Toolkit.Data.List.AtIndex
import Toolkit.Data.DList
import Toolkit.Data.DList.AtIndex

import Toolkit.DeBruijn.Context.Item
import Toolkit.DeBruijn.Context
import Toolkit.DeBruijn.Renaming

%default total

namespace General
  public export
  interface Rename type term
         => Substitute (type : Type)
                       (term : List type -> type -> Type)
                             | term
    where

      subst : {old, new : List type}
           -> (f : {ty  : type}
                       -> IsVar old ty
                       -> term  new ty)
           -> ({ty : type}
                  -> term old ty
                  -> term new ty)

namespace Single
  %inline
  apply : {type : Type}
       -> {term : List type -> type -> Type}
       -> Rename type term
       => {ctxt   : List type}
       -> {typeA  : type}
       -> {typeB  : type}
       -> (this   : term   ctxt    typeB)
       -> (idx    : IsVar (ctxt += typeB) typeA)
                 -> term   ctxt           typeA
  apply this (V Z Here) = this
  apply this (V (S pos) (There later)) = embed (V pos later)

  export
  subst : {type : Type}
       -> {term : List type -> type -> Type}
       -> Rename type term
       => Substitute type term
       => {ctxt          : List type}
       -> {typeA         : type}
       -> {typeB         : type}
       -> (this          : term  ctxt           typeB)
       -> (inThis        : term (ctxt += typeB) typeA)
                        -> term  ctxt           typeA
  subst {ctxt} {typeA} {typeB} this inThis
    = General.subst (apply this) inThis

namespace Double

  %inline
  public export
  apply : {type : Type}
       -> {term : List type -> type -> Type}
       -> Rename type term
       => {ctxt          : List type}
       -> {typeA, typeB, typeC : type}
       -> (this    : term    ctxt                     typeA)
       -> (andThis : term    ctxt                     typeB)
       -> (idx     : IsVar ((ctxt += typeA) += typeB) typeC)
                  -> term    ctxt                     typeC
  apply this andThis pos = ?todo -- I know

  public export
  subst : {type : Type}
       -> {term : List type -> type -> Type}
       -> Rename type term
       => Substitute type term
       => {ctxt          : List type}
       -> {typeA, typeB, typeC : type}
       -> (this    : term  ctxt                     typeA)
       -> (andThis : term  ctxt                     typeB)
       -> (inThis  : term ((ctxt += typeA) += typeB) typeC)
                  -> term   ctxt                     typeC
  subst {ctxt} {typeA} {typeB} {typeC} this andThis inThis
    = General.subst (apply this andThis) inThis

-- [ EOF ]


module PrintF

----------------------------------------------------------------------
-- Aufwärmen

NNatsFun : Nat -> Type
NNatsFun Z = Nat
NNatsFun (S k) = Nat -> NNatsFun k

adder : (n:Nat) -> Nat -> NNatsFun n
adder Z acc = acc
adder (S k) acc = \n => adder k (acc+n)

----------------------------------------------------------------------
-- PRINTF

-- Beschreibt den Aufbau des Formatstrings:

data Format
     = Num Format
     | Str Format
     | Lit String Format
     | End

-- Typfunktion: Format -> Type

PrintfType : Format -> Type
PrintfType (Num rest) = Integer -> PrintfType rest
PrintfType (Str rest) = String -> PrintfType rest
PrintfType (Lit _ rest) = PrintfType rest
PrintfType End = String

-- Funktion mit Argumenten, die durch `format` gegeben werden
-- und die über `acc` die Ausgabe entsprechend des `format` erstellt

printfToString : (format : Format) -> (acc : String) -> PrintfType format
printfToString (Num rest) acc = \num => printfToString rest (acc ++ show num)
printfToString (Str rest) acc = \str => printfToString rest (acc ++ str)
printfToString (Lit out rest) acc = printfToString rest (acc ++ out)
printfToString End acc = acc

----------------------------------------------------------------------
-- Parsen
parseStringToFormat : String -> Format
parseStringToFormat input = parseChars (unpack input)
  where
    parseChars : List Char -> Format
    parseChars [] = End
    parseChars ('%' :: 'd' :: rest) = Num (parseChars rest)
    parseChars ('%' :: 's' :: rest) = Str (parseChars rest)
    parseChars (c :: rest) =
      case parseChars rest of
        Lit lit rest =>
          Lit (c `strCons` lit) rest
        sonst => Lit (pack [c]) sonst

----------------------------------------------------------------------
-- Endergebnis

printf : (format : String) -> PrintfType (parseStringToFormat format)
printf format = printfToString _ ""


foo : Nat -> Nat
foo x = ?foo_rhs

bar : Nat -> Nat
bar x = plus x ?bar_rhs

-- Rest of file


module Loops

import Data.Strings
import System

%default total

countdown : HasIO io => (secs : Nat) -> io ()
countdown Z = putStrLn "Lift-off!"
countdown (S k) = do putStrLn (show (S k))
                     usleep 1000000
                     countdown k

readNumber : HasIO io => io (Maybe Nat)
readNumber = do ns <- getLine
                if all isDigit (unpack ns)
                   then pure $ Just (stringToNatOrZ ns)
                   else pure Nothing

partial
countdowns : HasIO io => io ()
countdowns = do putStr "Enter starting number: "
                Just num <- readNumber
                  | Nothing => putStrLn "We accept only numbers, sorry!"
                countdown num
                putStr "Try again? [y/n]: "
                choice <- getLine
                if choice == "y" || choice == "yes"
                   then countdowns
                   else pure ()


main : IO ()
main = putStrLn ?greeting

even : Nat -> Bool
even Z = True
even (S k) = ?even_rhs


module Data.Word.Word8

-- We'll remove this module once Bits8 has more casts. Casting an Int to Integer
-- to cast to Bits8 isn't ideal.

-- TODO: Add modulo to base to incentivise backend support.
-- In Idris2 currently mod is really rem!
private
%foreign "scheme:modulo"
mod' : Int -> Int -> Int

private
mod256 : Int -> Int
mod256 x = mod' x 256

export
data Word8 : Type where
  W8 : Int -> Word8

private
fromInt : Int -> Word8
fromInt = W8 . mod256

%tcinline
private
fromInteger' : Integer -> Word8
fromInteger' = W8 . mod256 . cast

 -- might need to %tcinline this, depends how private affects things
private
%inline -- %spec or %inline? TODO: test each
word8Over : (f : Int -> Int -> Int) -> Word8 -> Word8 -> Word8
word8Over f (W8 x) (W8 y) = W8 $ mod256 (x `f` y)

export
implementation
Num Word8 where
  (+) = word8Over (+)
  (*) = word8Over (*)
  -- Careful, silently overflows as a literal.
  fromInteger x = if x >= 0 && x < 256
                    then W8 $ cast x
                    else fromInteger' x

export
implementation
Integral Word8 where
  mod = word8Over mod
  div = word8Over div

export
implementation
Neg Word8 where
  negate = word8Over (-) 0
  (-)    = word8Over (-)

export
implementation
Eq Word8 where
  W8 x == W8 y = x == y

export
implementation
Ord Word8 where
    W8 x `compare` W8 y = x `compare` y

export
implementation
Cast Int Word8 where
  cast = fromInt

export
implementation
Cast Word8 Int where
  cast (W8 i) = i

export
implementation
Cast Word8 Bits8 where
  cast = believe_me

export
implementation
Cast Bits8 Word8 where
  cast = W8 . believe_me

export
Show Word8 where
  show (W8 i) = show i


{--
Copyright 2021 Joel Berkeley

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
--}
||| This module contains definitions and utilities for datasets.
module Data

import Tensor

||| Observed pairs of data points from feature and target domains. Data sets such as this are
||| commonly used in supervised learning settings.
|||
||| @features The shape of the feature domain.
||| @targets The shape of the target domain.
public export
data Dataset : (0 features : Shape) -> (0 targets : Shape) -> Type where
  MkDataset : {s : _} -> Tensor (S s :: features) Double
           -> Tensor (S s :: targets) Double
           -> Dataset features targets

||| Concatenate two datasets along their leading axis.
export
Semigroup (Dataset features targets) where
  (MkDataset x y) <+> (MkDataset x' y') = MkDataset (concat x x') (concat y y')


module Control.Monad.Freer

import Control.Monad.Free
import Control.Monad.Syntax
import Data.CoList

%default total
%access public export

-- ported from https://github.com/robrix/freer-cofreer

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

Functor (Freer f) where
  map f (Pure result)     = Pure (f result)
  map f (Bind step yield) = Bind step (\x => map f $ yield x)

Applicative (Freer f) where
  pure = Pure

  (Pure f)            <*> param = map f param
  (Bind action yield) <*> param = Bind action (\x => (yield x) <*> param)

Monad (Freer f) where
  (Pure a)   >>= f = f a
  (Bind r f) >>= g = Bind r (f >=> g)

liftF : f a -> Freer f a
liftF action = action `Bind` Pure

hoistFreer : {f, g : Type -> Type} -> (fg : {a : Type} -> f a -> g a) -> Freer f b -> Freer g b
hoistFreer _  (Pure result)     = Pure result
hoistFreer fg (Bind step yield) = Bind (fg step) (\x => hoistFreer fg $ yield x)

||| Tear down a `Freer` `Monad` using iteration with an explicit continuation.
|||
||| This is analogous to `iter` with a continuation for the interior values, and
||| is therefore suitable for defining interpreters for GADTs/types lacking a
||| `Functor` instance.
iterFreer : (algebra : {x : Type} -> (x -> a) -> f x -> a) -> Freer f a -> a
iterFreer _       (Pure result)          = result
iterFreer algebra (Bind action continue) = algebra (\x => iterFreer algebra $ continue x) action

||| Tear down a `Freer` `Monad` using iteration.
|||
||| This is analogous to `cata` where the `Pure`ed values are placeholders for
||| the result of the computation.
iter : Functor f => (algebra : f a -> a) -> Freer f a -> a
iter algebra = iterFreer (\yield => algebra . map yield)

||| Tear down a `Freer` `Monad` using iteration with an explicit continuation in some `Applicative` context.
|||
||| This is analogous to `iterA` with a continuation for the interior values, and
||| is therefore suitable for defining interpreters for GADTs/types lacking a
||| `Functor` instance.
iterFreerA : Applicative m => (algebra : {x : Type} -> (x -> m a) -> f x -> m a) -> Freer f a -> m a
iterFreerA algebra r = iterFreer algebra (map pure r)

||| Tear down a `Freer` `Monad` using iteration in some `Applicative` context.
|||
||| This is analogous to `cata` where the `Pure` values are placeholders for
||| the result of the computation.
iterA : (Functor f, Applicative m) => (algebra : f (m a) -> m a) -> Freer f a -> m a
iterA algebra = iterFreerA (\yield => algebra . map yield)

||| Run a program to completion by repeated refinement, and return its result.
-- TODO can it be made total? use `Fuel`?
partial
runFreer : (refine : {x : Type} -> f x -> Freer f x) -> Freer f result -> result
runFreer refine = iterFreer (\xa, fx => xa $ runFreer refine $ refine fx)

||| Run a program to completion by repeated refinement in some `Monad`ic
||| context, and return its result.
-- TODO can it be made total? use `Fuel`?
partial
runFreerM : Monad m => (refine : {x : Type} -> f x -> Freer f (m x)) -> Freer f result -> m result
runFreerM {m} refine r = go (map pure r)
  where
  partial
  go : Freer f (m x) -> m x
  go = iterFreer ((. (go . refine)) . (=<<))

||| Run a single step of a program by refinement, returning `Either` its result
||| or the next step.
stepFreer : (refine : {x : Type} -> f x -> Freer f x) -> Freer f result -> Either result (Freer f result)
stepFreer _      (Pure a)          = Left a
stepFreer refine (Bind step yield) = Right (refine step >>= yield)

||| Run a program to completion by repeated refinement, returning the list of
||| steps up to and including the final result.
|||
||| The steps are unfolded lazily, making this total and suitable for stepwise
||| evaluation of nonterminating programs.
freerSteps : (refine : {x : Type} -> f x -> Freer f x) -> Freer f result -> CoList (Freer f result)
freerSteps refine r = case stepFreer refine r of
  Left  a    => [Pure a]
  Right step => step :: (freerSteps refine step)

retract : Monad m => Freer m a -> m a
retract = iterFreerA (=<<)

foldFreer : Monad m => ({x : Type} -> f x -> m x) -> Freer f a -> m a
foldFreer f = retract . hoistFreer f

cutoff : Nat -> Freer f a -> Freer f (Either (Freer f a) a)
cutoff  Z     r                = pure (Left r)
cutoff (S n) (Bind step yield) = Bind step (cutoff n . yield)
cutoff  _     r                = Right <$> r

MonadFree (Freer f) f where
  wrap action = action `Bind` id

Foldable f => Foldable (Freer f) where
  foldr ff c (Pure a)   = ff a c
  foldr ff c (Bind r t) = foldr (\x,c1 => foldr ff c1 (t x)) c r

Traversable f => Traversable (Freer f) where
  traverse f (Pure a)   = pure <$> f a
  traverse f (Bind r t) = wrap <$> traverse (\a => traverse f (t a)) r


-- ------------------------------------------------------------ [ Messages.idr ]
-- Module      : Messages
-- Description : Types for Crypto Messages
-- Copyright   : (c) Jan de Muijnck-Hughes
-- License     : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
module Crypto.Message

||| Representation if Messages
data Message : Nat -> Type where
  MkMsgData : Vect n Bits32 -> Message n

||| Representation of a ciphertext.
data Encrypted : Nat -> Type where
  MkEncData : Vect n Bits32 -> Encrypted n

||| Representation of a digital signature.
data Signed : Nat -> Type where
  MkSigData : Vect n Bits32 -> Signed n

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


module Algebra.Solver.Semiring

import public Algebra.Semiring
import public Algebra.Solver.Semiring.Expr
import public Algebra.Solver.Semiring.Prod
import public Algebra.Solver.Semiring.SolvableSemiring
import public Algebra.Solver.Semiring.Sum

%default total


-- examples in "Type-Driven Development with Idris"
-- chapter 13, section 1, Door part

-- check that all functions are total
%default total

data DoorState = DoorClosed | DoorOpen

data DoorCmd : Type ->
               DoorState ->
               DoorState ->
               Type where
  Open :     DoorCmd ()       DoorClosed DoorOpen
  Close :    DoorCmd ()       DoorOpen   DoorClosed
  RingBell : DoorCmd ()       DoorClosed DoorClosed
  Pure :     ty -> DoorCmd ty state      state
  (>>=) :    DoorCmd a        state1     state2 ->
             (a -> DoorCmd b  state2     state3) ->
             DoorCmd b        state1     state3

doorProg : DoorCmd () DoorClosed DoorClosed
doorProg = do RingBell
              Open
              Close


module RnaTranscription

import Data.Vect

%access export
%default total

namespace DnaStrand
  public export
  data DnaStrand = A | C | T | G

implementation Eq DnaStrand where
  (==) A A = True
  (==) C C = True
  (==) T T = True
  (==) G G = True
  (==) _ _ = False

namespace RnaStrand
  public export
  data RnaStrand = A | C | G | U

implementation Eq RnaStrand where
  (==) A A = True
  (==) C C = True
  (==) G G = True
  (==) U U = True
  (==) _ _ = False

toRna : Vect n DnaStrand -> Vect n RnaStrand
toRna [] = []
toRna (A :: xs) = U :: toRna xs
toRna (C :: xs) = G :: toRna xs
toRna (T :: xs) = A :: toRna xs
toRna (G :: xs) = C :: toRna xs


||| Internal functions used by HashMap and HashSet
module Data.HashMap.Internal

import Data.Array16
import public Data.Hashable

infix 6 `eq`

infixr 5 .&.
infixr 4 >>

||| Binary and.
%inline
(.&.) : Bits64 -> Bits64 -> Bits64
(.&.) = prim__and_Bits64

||| Right shift.
%inline
(>>) : Bits64 -> Bits64 -> Bits64
(>>) = prim__shr_Bits64

||| Mask for 4 bits.
export
data BitMask
    = BM0
    | BM1
    | BM2
    | BM3
    | BM4
    | BM5
    | BM6
    | BM7
    | BM8
    | BM9
    | BMa
    | BMb
    | BMc
    | BMd
    | BMe
    | BMf

||| Initial bit mask.
export
bitMask0 : BitMask
bitMask0 = BM0

public export
Hash : Type
Hash = Bits64

||| Mask 4 bits.
bitMask : BitMask -> Hash -> Bits64
bitMask mask h = case mask of
    BM0 => 0x000000000000000f .&. h >> 0x00
    BM1 => 0x00000000000000f0 .&. h >> 0x04
    BM2 => 0x0000000000000f00 .&. h >> 0x08
    BM3 => 0x000000000000f000 .&. h >> 0x0c
    BM4 => 0x00000000000f0000 .&. h >> 0x10
    BM5 => 0x0000000000f00000 .&. h >> 0x14
    BM6 => 0x000000000f000000 .&. h >> 0x18
    BM7 => 0x00000000f0000000 .&. h >> 0x1c
    BM8 => 0x0000000f00000000 .&. h >> 0x20
    BM9 => 0x000000f000000000 .&. h >> 0x24
    BMa => 0x00000f0000000000 .&. h >> 0x28
    BMb => 0x0000f00000000000 .&. h >> 0x2c
    BMc => 0x000f000000000000 .&. h >> 0x30
    BMd => 0x00f0000000000000 .&. h >> 0x34
    BMe => 0x0f00000000000000 .&. h >> 0x38
    BMf => 0xf000000000000000 .&. h >> 0x3c

||| Get the `BitMask` for the next 4 bits.
nextBitMask : BitMask -> BitMask
nextBitMask = \case
    BM0 => BM1
    BM1 => BM2
    BM2 => BM3
    BM3 => BM4
    BM4 => BM5
    BM5 => BM6
    BM6 => BM7
    BM7 => BM8
    BM8 => BM9
    BM9 => BMa
    BMa => BMb
    BMb => BMc
    BMc => BMd
    BMd => BMe
    BMe => BMf
    BMf => BM0

||| Is this the last 4 bits?
isLastBM : BitMask -> Bool
isLastBM = \case
    BMf => True
    _ => False

public export
Salt : Type
Salt = Bits64

||| Get the next salt.
-- TODO: get better algorithm
nextSalt : Salt -> Salt
nextSalt = (2 +)

||| Return just if a predicate is satisfied.
justWhen : Bool -> Lazy a -> Maybe a
justWhen True x = Just x
justWhen False _ = Nothing

||| Return `Nothing` is predicate is false, else return other value.
joinWhen : Bool -> Lazy (Maybe a) -> Maybe a
joinWhen True x = x
joinWhen False _ = Nothing

||| Internal Hash-array map trie (HAMT) that assumes the same hash and Eq is used.
export
data HashArrayMapTrie k v
    = Empty
    | Leaf Hash k v -- full hash
    | Collision Hash Salt (HashArrayMapTrie k v) -- full hash
    | Node (Array16 (HashArrayMapTrie k v))

export
Functor (HashArrayMapTrie k) where
    map _ Empty = Empty
    map f (Leaf h k v) = Leaf h k (f v)
    map f (Collision h s m) = Collision h s (map f m)
    map f (Node arr) = Node (map (map f) arr)

||| An empty HAMT.
export
empty : HashArrayMapTrie k v
empty = Empty

||| A HAMT containing one key and value.
export
singleton : Hash -> k -> v -> HashArrayMapTrie k v
singleton = Leaf

||| Create a HAMT from 2 keys and values, which have different hashes.
node2 : BitMask -> Hash -> k -> v -> Hash -> k -> v -> HashArrayMapTrie k v
node2 bm h0 k0 v0 h1 k1 v1 = Node $
    write (bitMask bm h0) (Leaf h0 k0 v0) $
    write (bitMask bm h1) (Leaf h1 k1 v1) $
    new Empty

mutual
    ||| Create a HAMT from 2 keys and values, where the hashes collide.
    collision2 :
        (eq : k -> k -> Bool) ->
        (hashWithSalt : Salt -> k -> Hash) ->
        Salt -> Hash ->
        k -> v -> k -> v ->
        HashArrayMapTrie k v
    collision2 eq hws s0 h k0 v0 k1 v1 =
        let s1 = nextSalt s0
            h0 = hws s1 k0
            h1 = hws s1 k1
            m0 = insert eq hws s1 BM0 h0 k0 v0
                $ insert eq hws s1 BM0 h1 k1 v1
                Empty
        in Collision h s1 m0

    export
    ||| Insert a key and value into a HAMT, replacing any existing values.
    insert :
        (eq : k -> k -> Bool) ->
        (hashWithSalt : Salt -> k -> Hash) ->
        Salt ->
        BitMask ->
        Hash ->
        k ->
        v ->
        HashArrayMapTrie k v ->
        HashArrayMapTrie k v
    insert eq hws s0 bm0 h0 k0 v0 m0 = case m0 of
        Empty => Leaf h0 k0 v0
        Leaf h1 k1 v1 => if h0 /= h1
            then node2 bm0 h0 k0 v0 h1 k1 v1
            else if k0 `eq` k1
                then Leaf h0 k0 v0
                else collision2 eq hws s0 h0 k0 v0 k1 v1
        Collision h1 s1 m1 => if h0 == h1
            then Collision h1 s1
                $ insert eq hws s1 BM0 (hws s1 k0) k0 v0 m1
            else -- hashes are different so it can't be the last bit mask
                Node $
                update (bitMask bm0 h0) (insert eq hws s0 (nextBitMask bm0) h0 k0 v0) $
                write (bitMask bm0 h1) m0 $
                new Empty
        Node ar =>
            Node $ update (bitMask bm0 h0)
            (insert eq hws s0 (nextBitMask bm0) h0 k0 v0) ar

||| Delete a key and value from a HAMT.
export
delete :
    (eq : k -> k -> Bool) ->
    (hashWithSalt : Salt -> k -> Hash) ->
    BitMask ->
    Hash -> k ->
    HashArrayMapTrie k v ->
    HashArrayMapTrie k v
delete eq hws bm0 h0 k0 m0 = case m0 of
    Empty => Empty
    Leaf h1 k1 v1 => if h0 == h1 && k0 `eq` k1
        then Empty
        else Leaf h1 k1 v1
    Collision h1 s1 m1 => if h0 == h1
        then Collision h1 s1
            $ delete eq hws BM0 (hws s1 k0) k0 m1
        else m0
    Node ar => Node $ update (bitMask bm0 h0) (delete eq hws (nextBitMask bm0) h0 k0) ar

||| Lookup a value at a key in a HAMT.
export
lookup :
    (eq : k -> k -> Bool) ->
    (hashWithSalt : Salt -> k -> Hash) ->
    BitMask ->
    Hash -> k ->
    HashArrayMapTrie k v ->
    Maybe v
lookup eq hws bm0 h0 k0 m0 = case m0 of
    Empty => Nothing
    Leaf h1 k1 v => justWhen (h0 == h1 && k0 `eq` k1) v
    Collision h1 s m1 => joinWhen (h0 == h1)
        $ lookup eq hws BM0 (hws s k0) k0 m1
    Node ar => lookup eq hws (nextBitMask bm0) h0 k0 $ index (bitMask bm0 h0) ar

||| Fold a HAMT with the key and value.
||| Note: this is based on the order of the hash not the key.
export
foldWithKey : (k -> v -> acc -> acc) -> acc -> HashArrayMapTrie k v -> acc
foldWithKey _ z Empty = z
foldWithKey f z (Leaf _ k v) = f k v z
foldWithKey f z (Collision _ _ m) = foldWithKey f z m
foldWithKey f z (Node ar) = foldr (flip $ foldWithKey f) z ar


Y : Type
X : Type
Term : Type -> Type

erase : Term a -> Y

unc : (x : Term a) -> erase x = y -> (x : Term a ** erase x = y)
unc x p = (x ** p)

f : (x : Term a) -> erase x = y -> X = a -> (x' : Term X ** erase x' = y)
f x h p = rewrite p in unc x h


module Main

import Effects
import Effect.StdIO
import Effect.Random

data GameState = NotRunning
               | Running Nat

data GameInfo : GameState -> Type where
     Number : (guesses : Nat) ->
              (answer : Int) -> GameInfo (Running (S guesses))
     Lost : (answer : Int) -> GameInfo (Running Z)
     Init : GameInfo NotRunning

data Result = TooLow | Correct | TooHigh

data GuessNumber : Effect where
     GuessNum : Int ->
             sig GuessNumber Result
                 (GameInfo (Running (S k)))
                 (\guess =>
                       GameInfo (case guess of
                                      Correct => NotRunning
                                      _ => Running k))
     Quit : sig GuessNumber Int (GameInfo (Running Z)) (GameInfo NotRunning)

GUESS : GameState -> EFFECT
GUESS t = MkEff (GameInfo t) GuessNumber

guess : Int -> { [GUESS (Running (S k))] ==>
                 {guess} [GUESS (case guess of
                                      Correct => NotRunning
                                      _ => Running k)] } Eff Result
guess n = call $ GuessNum n

quit : Eff Int [GUESS (Running Z)] [GUESS NotRunning]
quit = call Quit

Handler GuessNumber m where
    handle (Number g n) (GuessNum i) k with (compare i n)
      handle (Number (S g) n) (GuessNum i) k | LT = k TooLow (Number g n)
      handle (Number Z n) (GuessNum i) k | LT = k TooLow (Lost n)
      handle (Number g n) (GuessNum i) k | EQ = k Correct Init
      handle (Number Z n) (GuessNum i) k | GT = k TooHigh (Lost n)
      handle (Number (S g) n) (GuessNum i) k | GT = k TooHigh (Number g n)
    handle (Lost n) Quit k = k n Init

game : Eff () [GUESS (Running n), STDIO] [GUESS NotRunning, STDIO]
game {n=Z} = do putStrLn "You lose"
                ans <- quit
                putStrLn $ "The answer was " ++ show ans
game {n=S g}
     = do putStr "Guess: "
          let num = cast (trim !getStr)
          case !(guess num) of
               TooLow => do putStrLn "Too low"
                            game
               Correct => putStrLn "You win!"
               TooHigh => do putStrLn "Too high"
                             game

main : IO ()
main = runInit [Number 5 42, ()] game


module Tools.Annotation

import Tools.Indexed
import Tools.AstF

%access public export

AstFTy : Type -> Type
AstFTy idx = (idx -> Type) -> (idx -> Type)

data Annotated : (idx : Type) -> (f : AstFTy idx)
              -> (i : idx) -> (ann : Type) -> Type where
  Ann : (a : ann) -> f (\id => Annotated idx f id ann) i -> Annotated idx f i ann

AstF idx f => IxFunctor idx (Annotated idx f) where
  imap {b} {a} {i} fn (Ann x rec) = Ann (fn x)
                          $ localMap (\id => Annotated idx f id a)
                                     (\id => Annotated idx f id b)
                                     (\id => imap {i = id} fn)
                                     i rec

AstF idx f => IxCopointed idx (Annotated idx f) where
  iextract (Ann x _) = x


module Sub13Apply108x36

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total
-- %language ElabReflection

-- 3(36x+12) --F[5,-2]->B[1,-2]--> 3(16x+5)
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)))))))))))) 2
    -> 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))))))))) 2
fb108x36To48x15 o prf =
  let prf2 = lvDown (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)))))))))))) 2
                    prf in
    let prf3 = fb108x36To48x15' o prf2 in lvDown (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 prf3

export
apply108x36 : 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)))))))))))) 2
  -> (m : Nat **
        (LTE (S m)
             (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)))))))))))),
         P m 2))
apply108x36 {o} col = let col2 = fb108x36To48x15 o col in ((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)))))))))
                                                           ** (lte108x36 o, col2)) where
  lte108x36 : (o:Nat) -> LTE (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))))))))))
          (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))))))))))))
  lte108x36 Z = (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
  lte108x36 (S o) = let lemma = lte108x36 o in

    rewrite (sym (plusSuccRightSucc o o)) in

    rewrite (sym (plusSuccRightSucc (plus o o)  (S (plus o o)))) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (plus o o))) in

    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (S (plus (plus o o) (plus o o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (plus (plus o o) (plus o o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (plus (plus o o) (plus o o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (plus (plus o o) (plus o o)))) in

    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))) in
    rewrite (sym (plusSuccRightSucc (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))))) in

    rewrite (sym (plusSuccRightSucc (plus o o)  o)) in

    rewrite (sym (plusSuccRightSucc (plus (plus o o) o)  (S (S (plus (plus o o) o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) o)  (S (plus (plus o o) o)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) o)  (plus (plus o o) o))) in

    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))
              (S (S (S (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))
              (S (S (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))
              (S (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))
              (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))
              (S (S (plus (plus (plus o o) o) (plus (plus o o) o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))
              (S (plus (plus (plus o o) o) (plus (plus o o) o))))) in

    rewrite (sym (plusSuccRightSucc (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 (S (S (S (S (S (S (S (S (S (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))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (S (S (S (S (S (S (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)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (S (S (S (S (S (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))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (S (S (S (S (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)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (S (S (S (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))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (S (S (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)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (S (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))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (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)))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (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))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (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)))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (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))))))))) in
    rewrite (sym (plusSuccRightSucc (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)))))))) in

    rewrite (sym (plusSuccRightSucc (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 (S (S (S (S (S (S (S (S (S (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))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (S (S (S (S (S (S (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)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (S (S (S (S (S (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))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (S (S (S (S (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)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (S (S (S (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))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (S (S (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)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (S (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))))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (S (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)))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (S (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))))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (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)))))))))) in
    rewrite (sym (plusSuccRightSucc (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 (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))))))))) in
    rewrite (sym (plusSuccRightSucc (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)))))))) in

      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) lemma


import Control.Monad.Identity

public export
interface Foo (sA : Type) where
  A : Type
  Elem : A -> sA -> Type
  Empty : sA -> Type
  Empty as = (a : A) -> Not (Elem a as)

public export
implementation Foo (Identity Bool) where
  A = Bool
  Elem x (Id y) = x = y


module Main

import Graph

test : Graph String String
test = ([("a", 0)], 1, "World", [("loop", 1)]) & ([], 0, "Hello", []) & empty

main : IO ()
main = putStrLn . graphToDot $ test


module Test.Transducers.Core

import Transducers
import Test.Transducers.Utils

--------------------------------------------------------------------------------
-- Unit tests
--------------------------------------------------------------------------------

should_map : List Int -> Test
should_map input =
  assertEq
    (foldl (+) 0 (map (*2) input))
    (transduce (mapping (*2)) (+) 0 input)

should_follow_map_law : Test
should_follow_map_law =
  assertEq
    (transduce (mapping length . mapping (*2)) (+) 0 ["abc", "", "cdef", "g"])
    (transduce (mapping ((*2) . length)) (+) 0 ["abc", "", "cdef", "g"])

should_filter : List Int -> Test
should_filter input =
  assertEq
    (foldl (+) 0 (filter odd input))
    (transduce (filtering odd) (+) 0 input)

should_concat_map : List Int -> Test
should_concat_map input =
  assertEq
    (foldl (+) 0 (concatMap twice input))
    (transduce (catMapping twice) (+) 0 input)

should_reduce_terminal : List Int -> Test
should_reduce_terminal input =
  assertEq
    (foldl (+) 0 (filter odd (map (*2) input)))
    (reduce (mapping (*2) . filtering odd $ terminal (+)) 0 input)

should_take : List Int -> Test
should_take input =
  assertEq
    (foldl (+) 0 (take 10 input))
    (transduce (taking 10) (+) 0 input)

should_take_while : Test
should_take_while =
  assertEq 55 $ transduce (takingWhile (<= 10)) (+) 0 [1..100]

should_drop : List Int -> Test
should_drop input =
  assertEq
    (foldl (+) 0 (drop 10 input))
    (transduce (dropping 10) (+) 0 input)

should_pipe_from_left_to_right : List Int -> Test
should_pipe_from_left_to_right input =
  assertEq
    (foldl (+) 0 (map (+1) (concatMap twice (filter odd input))))
    (transduce (filtering odd . catMapping twice . mapping (+1)) (+) 0 input)

should_allow_pure_xf_composition : Test
should_allow_pure_xf_composition =
  let xf = taking 10 . filtering odd . mapping (*2)
  in do
    assertEq 50 (transduce xf (+) 0 [1..100])
    assertEq 30240 (transduce xf (*) 1 [1..100])
    assertEq 0 (transduce (mapping length . mapping fromNat . xf) (+) 0 (replicate 100 "ab"))

should_index : Test
should_index = do
  let xf = indexing . mapping (\(idx, s) => show idx ++ ": " ++ s) . interspersing ", "
  assertEq "0: Zero, 1: One, 2: Two" (transduce xf (++) "" ["Zero", "One", "Two"])

should_chunk_of : Test
should_chunk_of = do
  let xf = chunksOf 4 . mapping pack . mapping (++ " ")
  assertEq "abcd efgh ijkl " (transduce xf (++) "" ['a'..'l'])
  assertEq "abcd efgh ij " (transduce xf (++) "" ['a'..'j'])

should_intersperse : Test
should_intersperse = do
  let cs = ["a", "list", "of", "words"]
  assertEq "a, list, of, words" (transduce (interspersing ", ") (++) "" cs)

should_deduplicate : Test
should_deduplicate = do
  assertEq "abcdcbad" $ transduce (mapping singleton . deduplicate) (++) "" (unpack "abbcddccbaad")

should_group_by : Test
should_group_by =
  assertEq ["aa", "b", "ccc", "b"] $
    reverse $ into [] (groupingBy (==) . mapping pack) (unpack "aabcccb")

should_group_by_with_custom_predicate : Test
should_group_by_with_custom_predicate =
  assertEq 3 $ longestIncreasingSeq [1, 2, 1, 3, 4, 1, 5, 3, 4]
  where
    longestIncreasingSeq = transduce (groupingBy (<) . mapping length . mapping fromNat) max 0

should_support_isomorphisms : Test
should_support_isomorphisms =
  assertEq "ei" $
    into "" (under (MkIso ord chr) (mapping (+1)) . filtering vowel) (unpack "abcdefgh")

export
run_tests : IO ()
run_tests =
  runTestSuite [
    should_map [1..100],
    should_follow_map_law,
    should_filter [1..100],
    should_concat_map [1..100],
    should_reduce_terminal [1..100],
    should_take [1..100],
    should_take_while,
    should_drop [1..100],
    should_pipe_from_left_to_right [1..100],
    should_allow_pure_xf_composition,
    should_index,
    should_chunk_of,
    should_intersperse,
    should_deduplicate,
    should_group_by,
    should_group_by_with_custom_predicate,
    should_support_isomorphisms]


module VerifiedInvertible

%default total
%hide Prelude.Algebra.(<*>)
%hide Prelude.Applicative.(<|>)

-- http://www.informatik.uni-marburg.de/~rendel/unparse/

-- core definitions

data T = tt

data PartIso : Type -> Type -> Type where
  MkPartIso : (to : a -> Maybe b) ->
              (from : b -> Maybe a) ->
              (toFrom : (y : b) -> maybe T (\x => x = y) (from y >>= to)) ->
              (fromTo : (x : a) -> maybe T (\y => y = x) (to x >>= from)) ->
              PartIso a b

class PartIsoFunctor (f : Type -> Type -> Type) where
  (<$>) : PartIso a b -> (f a c -> f b c)

class PFunctor (f : Type -> Type -> Type) where
  (<*>) : f a c -> Lazy (f b c) -> f (a, b) c

class PAlternative (f : Type -> Type -> Type) where
  (<|>) : f a c -> Lazy (f a c) -> f a c
  empty : f a c

class (PartIsoFunctor d, PFunctor d, PAlternative d) => Syntax (d : Type -> Type -> Type) c where
  pure : Eq a => a -> d a c
  item : d c c

-- helper functions

ipc_inverse : PartIso a b -> PartIso b a
ipc_inverse (MkPartIso f g tf ft) = MkPartIso g f ft tf

ipc_apply : PartIso a b -> a -> Maybe b
ipc_apply (MkPartIso f g ft ft) = f

ipc_unapply : PartIso a b -> b -> Maybe a
ipc_unapply = ipc_apply . ipc_inverse

-- Inspect and other stuff

data Inspect : a -> Type where
  wi : {A : Type} -> (x : A) -> (y : A) -> (eq: x = y) -> Inspect x

inspect : {A : Type} -> (x : A) -> Inspect x
inspect x = wi x _ refl

match : {A : Type} -> {x : A} -> (y : A) -> {eq : x = y} -> Inspect x
match y {eq} = wi _ y eq

maybe_assoc : (x : Maybe a) -> (f : a -> Maybe b) -> (g : b -> Maybe c) -> (x >>= (\y => f y >>= g)) = (x >>= f >>= g)
maybe_assoc Nothing f g = refl
maybe_assoc (Just x) f g = refl

maybe_unbind : (f : a -> Maybe b) -> (g : b -> Maybe c) -> (x : a) -> {y : b} ->
  (f x = Just y) -> g y = Just x >>= f >>= g
maybe_unbind f g x eq = rewrite eq in refl

-- Algebra

infixr 1 >=>
(>=>) : Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
f >=> g = \x => f x >>= g

pId : PartIso a a
pId = MkPartIso (\x => Just x) (\x => Just x) (\x => refl) (\x => refl)

(.) : PartIso b c -> PartIso a b -> PartIso a c
(MkPartIso gTo gFrom gTF gFT) . (MkPartIso fTo fFrom fTF fFT) =
  MkPartIso
    (ipc_apply (MkPartIso fTo fFrom fTF fFT) >=> ipc_apply (MkPartIso gTo gFrom gTF gFT))
    (ipc_unapply (MkPartIso gTo gFrom gTF gFT) >=> ipc_unapply (MkPartIso fTo fFrom fTF fFT))
    tf ft
  where
    -- these two are identical, would be nice to generalize
    tf y with (inspect $ gFrom y)
      | match Nothing {eq=eq} = rewrite eq in tt
      | match (Just tfy) {eq=eq} = rewrite eq in
        rewrite (maybe_assoc ((Just tfy) >>= fFrom) fTo gTo) in
          case (inspect $ fFrom tfy >>= fTo) of
            match Nothing {eq=eq2} => rewrite eq2 in tt
            match (Just tfy') {eq=eq2} => rewrite eq2 in
              rewrite (replace eq2 {P=(\y => maybe T (\x => x = tfy) y)} (fTF tfy)) in
                rewrite (maybe_unbind gFrom gTo y eq) in (gTF y)
    ft y with (inspect $ fTo y)
      | match Nothing {eq=eq} = rewrite eq in tt
      | match (Just gty) {eq=eq} = rewrite eq in
        rewrite (maybe_assoc ((Just gty) >>= gTo) gFrom fFrom) in
          case (inspect $ gTo gty >>= gFrom) of
            match Nothing {eq=eq2} => rewrite eq2 in tt
            match (Just gty') {eq=eq2} => rewrite eq2 in
              rewrite (replace eq2 {P=(\y => maybe T (\x => x = gty) y)} (gFT gty)) in
                rewrite (maybe_unbind fTo fFrom y eq) in (fFT y)

-- pTup : PartIso a b -> PartIso c d -> PartIso (a, c) (b, d)
-- pTup i j = MkPartIso f g where
--   f (a, b) = case (ipc_apply i a) of
--     Nothing => Nothing
--     Just x => case (ipc_apply j b) of
--       Nothing => Nothing
--       Just y => Just (x, y)
--   g (c, d) = case (ipc_unapply i c) of
--     Nothing => Nothing
--     Just x => case (ipc_unapply j d) of
--       Nothing => Nothing
--       Just y => Just (x, y)

-- associate : PartIso (a, (b, c)) ((a, b), c)
-- associate = MkPartIso f g where
--   f (a, (b, c)) = Just ((a, b), c)
--   g ((a, b), c) = Just (a, (b, c))

commute : PartIso (a, b) (b, a)
commute = MkPartIso f f (\(a,b) => refl) (\(a,b) => refl) where
  f : (c, d) -> Maybe (d, c)
  f (a, b) = Just (b, a)

unit : {a : Type} -> PartIso a (a, ())
unit = MkPartIso f g tf ft where
  f : {a : Type} -> a -> Maybe (a, ())
  f a = Just (a, ())
  g : {a : Type} -> (a, ()) -> Maybe a
  g (a, ()) = Just a
  tf (a, ()) = refl
  ft a = refl

-- *>, <*

infixl 3 *>
(*>) : Syntax d c => d () c -> d a c -> d a c
p *> q = ipc_inverse unit . commute <$> p <*> q

infixl 3 <*
(<*) : Syntax d c => d a c -> d () c -> d a c
p <* q = ipc_inverse unit <$> p <*> q

-- this function can't be verified: there's no isomorphism when we are
-- ignoring input; neither can it be changed, because it's quite
-- important to be able to ignore input
ignore : a -> PartIso a ()
ignore x = MkPartIso f g tf ft where
  f : a -> Maybe ()
  f y = Just ()
  g : () -> Maybe a
  g () = Just x
  tf () = refl
  ft y = believe_me (x = y)

-- Parser

data Parser a c = MkParser (List c -> Maybe (a, List c))

parse : Parser a c -> List c -> Maybe a
parse (MkParser p) s = p s >>= pure . fst

instance PartIsoFunctor Parser where
  iso <$> (MkParser p) = MkParser pf
  where
    pf l = do
      (x, rest) <- p l
      y <- ipc_apply iso x
      return (y, rest)

instance PFunctor Parser where
  (MkParser p) <*> mkpq = MkParser pf
  where
    pf l = do
      (x, rest) <- p l
      case mkpq of
        (MkParser q) => do
          (y, ret) <- q rest
          return ((x, y), ret)

instance PAlternative Parser where
  (MkParser p) <|> mkpq = MkParser pf
  where
    pf l = case p l of
      Just x => Just x
      Nothing => case mkpq of
        (MkParser q) => q l
  empty = MkParser (\s => Nothing)

instance Syntax Parser c where
  pure x = MkParser (\s => Just (x, s))
  item = MkParser f
  where
    f [] = Nothing
    f (x :: xs) = Just (x, xs)

-- Printer

data Printer a c = MkPrinter (a -> Maybe (List c))

compose : Printer a c -> a -> Maybe (List c)
compose (MkPrinter p) x = p x

instance PartIsoFunctor Printer where
  iso <$> (MkPrinter p) = MkPrinter (\b => ipc_unapply iso b >>= p)

instance PFunctor Printer where
  (MkPrinter p) <*> mkpq = MkPrinter pf
  where
    pf (x, y) = do
      x' <- p x
      case mkpq of
        (MkPrinter q) => do
          y' <- q y
          return (x' ++ y')

instance PAlternative Printer where
  (MkPrinter p) <|> mkpq = MkPrinter $ \s =>
    case (p s) of
      Nothing => case mkpq of
        (MkPrinter q) => q s
      x => x
  empty = MkPrinter (\s => Nothing)

instance Syntax Printer γ where
  pure x = MkPrinter (\y =>
    if x == y
    then Just []
    else Nothing)
  item = MkPrinter (\t => Just [t])

-- Basic parsers/composers

sat : Syntax d a => (a -> Bool) -> d a a
sat {a} p = (MkPartIso check check verify verify) <$> item
  where
    check : a -> Maybe a
    check x = if p x then Just x else Nothing
    verify y with (inspect $ p y)
      | match False {eq=eq} = rewrite eq in tt
      | match True {eq=eq} = rewrite eq in
        rewrite eq in refl

val : (Syntax d a, Eq a) => a -> d a a
val x = sat (== x)

-- -- rep

-- nilv : PartIso () (Vect 0 a)
-- nilv = MkPartIso (const . Just $ Vect.Nil {a=a})
--                  (\xs => case xs of
--                    [] => Just ()
--                    _ => Nothing)

-- consv : PartIso (a, Vect n a) (Vect (S n) a)
-- consv = MkPartIso c1 c2
--   where c1 (x, xs) = Just (x :: xs)
--         c2 (x :: xs) = Just (x, xs)

-- rep : Syntax d c => (n : Nat) -> d a c -> d (Vect n a) c
-- rep Z p = nilv <$> pure ()
-- rep (S k) p = consv <$> p <*> rep k p

-- -- many

-- nil : PartIso () (List a)
-- nil = MkPartIso c1 c2
--   where
--     c1 () = Just []
--     c2 [] = Just ()
--     c2 (x :: xs) = Nothing

-- cons : PartIso (a, List a) (List a)
-- cons = MkPartIso c1 c2
--   where
--     c1 (x, l) = Just $ x :: l
--     c2 [] = Nothing
--     c2 (x :: xs) = Just (x, xs)

-- partial many : Syntax d c => d a c -> d (List a) c
-- many p = (cons <$> (p <*> (many p)))
--      <|> (nil <$> pure ())

-- -- Various types

-- -- List Bool <-> Nat, with size and endianness

-- data Endianness = BE | LE

-- order : Endianness -> Vect n Bool -> Vect n Bool
-- order BE = reverse
-- order LE = id

-- natToBits : Nat -> Endianness -> (k : Nat) -> Vect k Bool
-- natToBits n e v = order e $ natToBits' n v
--   where natToBits' : Nat -> (k : Nat) -> Vect k Bool
--         natToBits' n Z = []
--         natToBits' Z bits = replicate bits False
--         natToBits' n (S bits) = (mod n 2 /= Z) :: natToBits' (div n 2) bits

-- bitsToNat : Vect n Bool -> Endianness -> Nat
-- bitsToNat v e = bitsToNat' (order e v)
--   where bitsToNat' : Vect k Bool -> Nat
--         bitsToNat' [] = Z
--         bitsToNat' (v :: l) = (if v then 1 else 0) + 2 * bitsToNat' l

-- nat : Syntax d Bool => Endianness -> Nat -> d Nat Bool
-- nat endianness size = MkPartIso pf cf <$> rep size item
--   where
--     pf l = Just $ bitsToNat l endianness
--     cf x = Just $ natToBits x endianness size

-- testing

test : Syntax d Nat => d (Nat, Nat) Nat
test = (val 1) <*> item
   <|> (val 2) <*> (val 3)

-- test2 : Syntax d Bool => d (Nat, Bool) Bool
-- test2 = (nat BE 4) <*> (val True)
--     <|> (nat BE 2) <*> (val False)

-- partial test3 : Syntax d Bool => d (Bool, List Nat) Bool
-- test3 = (val True) <*> ((ignore False <$> item) *> (many $ nat BE 4))
--     <|> (val False) <*> ((ignore True <$> item) *> (many $ nat LE 3))

-- -- compose test3 (False, [1,2,3])
-- -- parse test3 [False, True, False, False, False, True, False, True, True, False]

-- -- foldl

-- partial driver : (a -> Maybe a) -> (a -> a)
-- driver step state = case step state of
--   Just state' => driver step state'
--   Nothing => state

-- partial iterate : PartIso a a -> PartIso a a
-- iterate step = MkPartIso f g where
--   f = Just . driver (ipc_apply step)
--   g = Just . driver (ipc_unapply step)

-- step : PartIso (a, b) a -> PartIso (a, List b) (a, List b)
-- step i = (pTup i pId) . associate . (pTup pId (ipc_inverse cons))

-- partial foldl : PartIso (a, b) a -> PartIso (a, List b) a
-- foldl i = ipc_inverse unit . (pTup pId (ipc_inverse nil)) . iterate (step i)


data Bad = MkBad (Bad -> Int) Int
         | MkBad' Int

foo : Bad -> Int
foo (MkBad f i) = f (MkBad' i)
foo (MkBad' x) = x

foo2 : Bad -> Int
foo2 b = case b of
              MkBad f i => f (MkBad' i)
              MkBad' x => x

data T : Type -> Type where
     MkT : T (T a) -> T a

mutual
  data Bad1 = MkBad1 (Bad2 -> Int)
  data Bad2 = MkBad2 (Bad1 -> Int)

data T2 : Type -> Type where
     MkT2 : T a -> T2 a


StringOrInt : Bool -> Type
StringOrInt x = case x of
  True => Int
  False => String

getStringOrInt : (x : Bool) -> StringOrInt x
getStringOrInt x = case x of
  True => 94
  False => "Ninety four"

valToString : (x : Bool) -> StringOrInt x -> String
valToString x val = case x of
  True => cast val
  False => val
  -- True => ?xTrueType
  -- False => ?xFalseType


-- --------------------------------------------------------------- [ PVect.idr ]
-- Module    : PVect.idr
-- Copyright : (c) 2015,2016 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| A `list` construct to create lists of dependent types.
|||
||| One of the problems with using dependent types is that types
||| depend on values. This affects the ability to construct lists of
||| values that have a dependent type. The existing `List` type cannot
||| be used as it requires all elements to have the same type.
module Data.PVect

import Data.Vect
import Data.DVect

import Data.DList

import public Decidable.Equality.Indexed

%default total
%access export

using (aTy : Type, elemTy : (aTy -> Type), x : aTy)

  ||| A list construct for dependent types.
  |||
  ||| @aTy    The type of the value contained within the list element type.
  ||| @len    The length of the list.
  ||| @elemTy The type of the elements within the list
  ||| @as     The List used to contain the different values within the type.
  public export
  data PVect : (aTy : Type)
            -> (elemTy : aTy -> Type)
            -> (predTy : aTy -> Type)
            -> (len : Nat)
            -> (as : Vect len aTy)
            -> (ps : DVect aTy predTy len as)
            -> Type where
    ||| Create an empty List
    Nil  : PVect aTy elemTy prfTy Z Nil Nil
    ||| Cons
    |||
    ||| @ex The element to add
    ||| @rest The list for `elem` to be added to.
    Ext : (ex : elemTy x)
       -> (pf : prfTy x)
       -> (rest : PVect aTy elemTy prfTy n xs ps)
       -> PVect aTy elemTy prfTy (S n) (x::xs) (pf::ps)

(++) : PVect aTy eTy pTy x     xs         xps
    -> PVect aTy eTy pTy y     ys         yps
    -> PVect aTy eTy pTy (x+y) (xs ++ ys) (xps ++ yps)
(++) xs ys with (xs)
  (++) xs ys | [] = ys
  (++) xs ys | (Ext ex pf rest) = Ext ex pf ((++) rest ys)

-- -------------------------------------------------------------- [ Form Tests ]
isNil : PVect aTy elemTy prfTy n as ps -> Bool
isNil Nil     = True
isNil (Ext x pf xs) = False

isCons : PVect aTy elemTy prfTy n as ps -> Bool
isCons l = isNil l == False

-- ------------------------------------------------------------------ [ Length ]

length : PVect aTy elemTy prfTy n as ps -> Nat
length {n} _ = n

-- ---------------------------------------------------------------- [ Indexing ]

index : (idx : Fin l)
     -> (vs : PVect aTy elemTy prfTy l as ps)
     -> elemTy (index idx as)
index FZ (Ext ex px rest) = ex
index (FS x) (Ext ex px rest) = index x rest

head : (vs : PVect aTy elemTy prfTy (S n) (a::as) (p::ps))
    -> (elemTy a, prfTy a)
head (Ext x p rest) = (x,p)

tail : (vs : PVect aTy eTy pTy (S n) (a :: as) (p :: ps))
    -> (PVect aTy eTy pTy n as ps)
tail (Ext ex px rest) = rest

last : (vs : PVect aTy eTy pTy (S n) as ps)
    -> (eTy (last as), pTy (last as))
last (Ext ex px rest) with (rest)
  last (Ext ex px rest) | [] = (ex, px)
  last (Ext ex px rest) | (Ext ey py xs) = last (Ext ey py xs)

init : (vs : PVect aTy eTy pTy (S n) as ps)
    -> PVect aTy eTy pTy n (init as) (init ps)
init (Ext ex px []) = []
init (Ext ex px (Ext ey py zs)) = Ext ex px $ init (Ext ey py zs)

take : (n : Nat)
    -> (vs : PVect aTy eTy pTy (n+m) as ps)
    -> PVect aTy eTy pTy n (take n as) (take n ps)
take Z vs = []
take (S k) (Ext ex px rest) = Ext ex px $ take k rest

{-
takeWhile' : ({i : aTy} -> eTy i -> Bool)
          -> (vs : DVect aTy eTy l is)
          -> (l' : Nat ** bs : Vect l' aTy ** DVect aTy eTy l' bs)
takeWhile' f Nil = (_ ** _ ** Nil)
takeWhile' f (ex :: rest) =
  if f ex
  then (_ ** _ ** DVect.(::) ex (snd $ snd (takeWhile' f rest)))
  else (_ ** _ ** Nil)

drop : (n  : Nat)
    -> (vs : DVect aTy eTy (n + m) as)
    -> DVect aTy eTy m (drop n as)
drop Z vs = vs
drop (S k) (ex :: rest) = drop k rest

dropWhile' : ({i : aTy} -> eTy i -> Bool)
          -> (vs : DVect aTy eTy l is)
          -> (l' : Nat ** bs : Vect l' aTy ** DVect aTy eTy l' bs)
dropWhile' f Nil = (_ ** _ ** Nil)
dropWhile' f (ex :: rest) =
  if f ex
  then dropWhile' f rest
  else (_ ** _ ** DVect.(::) ex rest)

replicate : (n : Nat)
         -> (e : eTy i)
         -> DVect aTy eTy n (replicate n i)
replicate Z e = []
replicate (S k) e = e :: replicate k e

equals : ({i,j : aTy} -> e i -> e j -> Bool)
       -> DVect aTy e a as
       -> DVect aTy e b bs
       -> Bool
equals _ Nil Nil = True
equals f (x::xs) (y::ys) =
  if f x y
  then equals f xs ys
  else False
equals _ _ _ = False

compare : ({i,j : aTy} -> e i -> e j -> Bool)
        -> ({i,j : aTy} -> e i -> e j -> Ordering)
        -> DVect aTy e a as
        -> DVect aTy e b bs
        -> Ordering
compare _ _ Nil Nil = EQ
compare _ _ Nil _   = LT
compare _ _ _   Nil = GT
compare e c (a::as) (b::bs) =
  if (not (e a b))
  then c a b
  else compare e c as bs

concat : (xss : DVect (Vect n iTy) (DVect iTy e n) m iis)
      -> DVect iTy e (m * n) (concat iis)
concat [] = Nil
concat (ex :: rest) = ex ++ concat rest

foldr : ({i : iTy} -> e i -> p -> p)
     -> p
     -> DVect iTy e l as
     -> p
foldr _ acc Nil = acc
foldr f acc (x::xs) = f x (foldr f acc xs)

foldl : ({i : iTy} -> p -> e i -> p)
     -> p
     -> DVect iTy e l as
     -> p
foldl f init Nil = init
foldl f init (x::xs) = foldl f (f init x) xs

namespace Clean
  traverse : Applicative f
          => (funcTy : aTy -> bTy)
          -> (func : {a : aTy} -> elemTy a -> f $ elemTyB (funcTy a))
          -> (xs   : DVect aTy elemTy n as)
          -> f (DVect bTy elemTyB n (map funcTy as))
  traverse fTy func Nil     = pure Nil
  traverse fTy func (x::xs) = [| DVect.(::) (func x) (traverse fTy func xs) |]

namespace ToVect
 traverseToVect : Applicative f
        => (func : {a : aTy} -> elemTy a -> f b)
        -> (xs   : DVect aTy elemTy n as)
        -> f (Vect n b)
 traverseToVect func Nil     = pure Nil
 traverseToVect func (x::xs) = [| (::) (func x) (ToVect.traverseToVect func xs) |]

traverseToVDP : Applicative f
             => {bTy : Type}
             -> {elemTyB : bTy -> Type}
             -> (func : {a : aTy}
                     -> elemTy a
                     -> f (c ** elemTyB c))
             -> (xs : DVect aTy elemTy n as)
             -> f (Vect n (b ** elemTyB b))
traverseToVDP func [] = pure Nil
traverseToVDP func (e :: rest) = [| Vect.(::) (func e) $ traverseToVDP func rest|]

mapToVect : ({i : iTy} -> e i -> b)
         -> DVect iTy e l as
         -> Vect l b
mapToVect _ Nil = Nil
mapToVect f (x::xs) = f x :: mapToVect f xs

mapToList : ({i : iTy} -> e i -> b)
         -> DVect iTy e l as
         -> List b
mapToList f Nil = Nil
mapToList f (ex :: rest) = f ex :: mapToList f rest

toList' : Vect l type -> List type
toList' [] = []
toList' (x :: xs) = x :: toList' xs

mapToDList : DVect iTy e l as
          -> DList iTy e (toList' as)
mapToDList [] = []
mapToDList (ex :: rest) = ex :: mapToDList rest

mapMaybeToVect : ({i : iTy} -> e i -> Maybe b)
              -> DVect iTy e l as
              -> (l' ** Vect l' b)
mapMaybeToVect f Nil = (_ ** Nil)
mapMaybeToVect f (x::xs) =
  let rest = mapMaybeToVect f xs in
   case f x of
     Nothing => rest
     Just y  => (_ ** y :: (snd rest))

zipWith : (fT : iTy -> jTy -> kTy)
       -> (fV : {i : iTy} -> {j : jTy} -> e i -> f j -> g (fT i j))
       -> (xs : DVect iTy e l as)
       -> (ys : DVect jTy f l bs)
       -> DVect kTy g l (zipWith fT as bs)
zipWith fT fV [] [] = []
zipWith fT fV (ex :: restx) (ey :: resty) =
    fV ex ey :: zipWith fT fV restx resty

-- -------------------------------------------------------------------- [ Show ]

show : (showFunc : {a : aTy} -> elemTy a -> String)
    -> (vs : DVect aTy elemTy l as)
    -> String
show showFunc vs {l} = unwords strL
  where
     asVStr : Vect l String
     asVStr = mapToVect showFunc vs

     strL : List String
     strL = ["["] ++ intersperse ","  (toList asVStr) ++ ["]"]

-- -------------------------------------------------------------------- [ Elem ]

data VElem : (iTy : Type)
          -> (elemTy : iTy -> Type)
          -> (e : elemTy i)
          -> (es : DVect iTy elemTy l is)
          -> (prf : Elem i is)
          -> Type
  where
    Hier : (x=y) -> VElem iTy eTy x (y::xs) Here
    Er   : (komst : VElem iTy eTy x xs later)
        -> VElem iTy eTy x (not_x::xs) (There later)

Uninhabited (VElem iTy eTy a Nil prf) where
  uninhabited (Hier _) impossible
  uninhabited (Er _) impossible

vectIsEmpty : DecEq iTy => VElem iTy eTy e [] prf -> Void
vectIsEmpty (Hier _) impossible
vectIsEmpty (Er _) impossible

elemsNotEqual : DecEqIdx iTy eTy => (contra : (ex = ey) -> Void) -> VElem iTy eTy ex (ey :: rest) Here -> Void
elemsNotEqual contra (Hier Refl) = contra Refl

notInVect : DecEqIdx iTy eTy
        => (contra : VElem iTy eTy ex rest later -> Void)
        -> VElem iTy eTy ex (ey :: rest) (There later) -> Void
notInVect contra (Er komst) = contra komst

isElem' : {eTy : iTy -> Type}
       -> (DecEqIdx iTy eTy)
       => (e  : eTy i)
       -> (es : DVect iTy eTy l is)
       -> (prf : Elem i is)
       -> Dec (VElem iTy eTy e es prf)
isElem' ex (ey :: rest) Here with (decEq ex ey Refl)
  isElem' ey (ey :: rest) Here | (Yes Refl) = Yes (Hier Refl)
  isElem' ex (ey :: rest) Here | (No contra) = No (elemsNotEqual contra)

isElem' ex (ey :: rest) (There later) with (isElem' ex rest later)
  isElem' ex (ey :: rest) (There later) | (Yes komst) = Yes (Er komst)
  isElem' ex (ey :: rest) (There later) | (No contra) =
    No (notInVect contra)

isElem : {eTy : iTy -> Type}
      -> (DecEqIdx iTy eTy)
      => (e  : eTy i)
      -> (es : DVect iTy eTy l is)
      -> {auto prf : Elem i is}
      -> Dec (VElem iTy eTy e es prf)
isElem e es {prf} = isElem' e es prf

dropElem : (as : DVect iTy eTy (S l) is)
        -> (prf : VElem iTy eTy a as idx)
        -> DVect iTy eTy l (dropElem is idx)
dropElem (a :: x) (Hier _) = x
dropElem {l = (S k)} (not_x :: xs) (Er komst) =
  not_x :: dropElem xs komst
-}
-- --------------------------------------------------------------------- [ EOF ]


module Test.Data.CatQueue

import Test.Assert
import Data.CatQueue

%access public export

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

foo : CatQueue Nat
foo = MkCatQueue [1,2,3] []

bar : CatQueue Nat
bar = MkCatQueue [] [3,2,1]

baz : CatQueue Nat
baz = MkCatQueue [] []

x : CatQueue Nat
x = MkCatQueue [1] [2,3,4]

y : CatQueue Nat
y = MkCatQueue [5,6] [7,8,9]

z : CatQueue Nat
z = MkCatQueue [10,11,12] [13]

showZ : IO ()
showZ =
  assertEq
    (show z)
    "MkCatQueue [10, 11, 12] [13]"

fooIsBar : IO ()
fooIsBar = assertEq foo bar

fooIsNotBaz : IO ()
fooIsNotBaz = assertNotEq foo baz

nullIsEmpty : IO ()
nullIsEmpty = assertTrue $ null (the (CatQueue String) neutral)

xyzAssociative : IO ()
xyzAssociative = do
  putStrLn $ show $ x <+> (y <+> z)
  putStrLn $ show $ (x <+> y) <+> z
  assertTrue $ x <+> (y <+> z) == (x <+> y) <+> z


||| Test if the type of variables bound in as patterns is correctly reported
||| by :typeat, both in the pattern and in the right hand side

f : Maybe Nat -> Nat
f x@(Just y@(S _)) = ?rhs1 x y
f _ = ?rhs2


module Calc.Mul

%default total

export
multiply : Int -> Int -> Int
multiply x y = x * y


module Average

average : (str1: String) -> Double
average str =  let
  numWords = Prelude.List.length (words str)
  totalLength = sum (map Prelude.Strings.length (words str))
  in
  cast totalLength / cast numWords