{- These files given an introductory look at programming in the (currently
 - pre-alpha) release of Idris2, a dependently typed programming language.
 - They can be run by installing Idris2 (not trivial at the moment), and
 - the interactive type-driven development features described are available
 - through the Idris Atom plugin. Not all features of dependently typed
 - programmming are touched on, most significantly equality proofs are not
 - discussed.
 -
 - While Haskell makes the claim "all values have types" Idris and other
 - dependently typed languages add the claim that "values are types and
 - types are values." -}

x : Int -- x has type Int (note the symbols : and :: are reversed from Haskell)
x = 4

y : Type -- y has type Type
y = Int  -- y's value is a type

z : Type -- the value Type has type Type as well.
z = Type

{- For proofs in our system to be sound, we should not have Type : Type
 - as this leads to paradoxes. We should instead have universes or levels
 - of types, i.e. Type : Type1, Type1 : Type2. This already exists in other
 - dependently typed languages and will eventually exist in Idris2. Don't
 - worry about this for now, as it will not be important to the examples.

 - To understand dependent types, we will first revisit polymorphism. What
 - are polymorphic values? They are functions on types. -}

-- Consider the polymorphic identity function
id : a -> a
id x = x

{- id2 below makes explicit in the type signature what is implicit above, that
 - it takes an initial {implicit} type argument and returns a monomorphic
 - identity function on that type. Since the value is implicit, Idris can
 - infer it from the other arguments. -}

id2 : {a : Type} -> a -> a -- takes a value `a` of type `Type`
id2 x = x                  -- and a value `x` of type `a`.

id3 : Int -> Int
id3 = id2 { a = Int } -- you can pass implicit arguments explicitly

{- We could also write an identity function with an explicit type parameter -}

id4 : (a : Type) -> a -> a
id4 a x = x

{- These are already examples of a "dependent type", where part of the type
 - (the type `a` of the second argument in this instance) depends on the
 - *value* `a` passed (possibly implicitly) as the first argument. -}


module ZipperTraversable

-- Based on http://okmij.org/ftp/continuations/zipper.html#traversable

import Control.Monad.Identity
import src.ContT

data Zipper : (t : Type -> Type) -> (a : Type) -> Type where
  ZDone : t a -> Zipper t a
  Z : a -> (Maybe a -> Zipper t a) -> Zipper t a

makeZipper : Traversable t => t a -> Zipper t a
makeZipper tr = runIdentity . reset $ traverse f tr >>= pure . ZDone
  where
    f : a -> Cont (Zipper t a) a
    f a = shift (\k => pure $ Z a (runIdentity . k . maybe a id))

update : Zipper List Int -> List Int
update (ZDone x) = x
update (Z x f) = update $ f (Just (x + 1))

test : List Int
test = update $ makeZipper [1..10]


module Test.Chapter7

import Test
import Exercises.Chapter7

%access public export

partial
testFunctorExpr1 : IO ()
testFunctorExpr1 =
 assertEq (map (*2) (the (Expr _) (1 + 2 * 3)))
          (Add (Val 2) (Mul (Val 4) (Val 6)))

-- testFunctorExpr2 :
--   map show (the (Expr _) (1 + 2 * 3)) = Add (Val "1") (Mul (Val "2") (Val "3"))


g1 : Nat -> Nat
g1 x = 5
--g1 _ = 6

g2 : (Nat, Nat) -> Nat
g2 (x, y) = x
--g2 (a, b) = 6

g3 : (Nat, Nat) -> Nat
g3 (x, y) = x
g3 _ = 6

f : Monad m => m (Nat, Nat)

h2 : Monad m => m Nat
h2 = do
  (x, y) <- f
  --  | (a, b) => pure 5
  pure x

h3 : Monad m => m Nat
h3 = do
  (x, y) <- f
    | _ => pure 5
  pure x


module Flexidisc.THList

%default total
%access export

||| `THList` stands for "TagLess Heterogenous list
||| It's a record demoted to an heterogeneous list,
||| where the label are only kept at the type lebvel
public export
data THList : (m : Type -> Type) -> (k : Type) -> (List (k, Type)) -> Type where
  Nil  : THList m k []
  (::) : m a -> THList m k xs -> THList m k ((l, a)::xs)

implementation Eq (THList m k []) where
  (==) x y = True
  (/=) x y = False

implementation (Eq (m t), Eq (THList m k ts)) => Eq (THList m k ((l,t)::ts)) where
  (==) (x :: xs) (y :: ys) = x == y && xs == ys
  (/=) (x :: xs) (y :: ys) = x /= y || xs /= ys

interface Shows t where
  shows : t -> List String

implementation Shows (THList m k []) where
  shows _ = []

implementation (Show k, Show (m t), Shows (THList m k ts)) =>
               Shows (THList m k ((l,t) :: ts)) where
  shows (x::xs) {l} = unwords [show l, ":=", show x] :: shows xs

implementation Shows (THList m k xs) => Show (THList m k xs) where
  show xs = unwords ["[", concat (intersperse ", " (shows xs)), "]"]


module Solutions.IO

import Data.List1
import Data.String

import System.File

%default total

--------------------------------------------------------------------------------
--          Pure Side Effects?
--------------------------------------------------------------------------------

-- 1
rep : (String -> String) -> IO ()
rep f = do
  s <- getLine
  putStrLn (f s)

-- 2
covering
repl : (String -> String) -> IO ()
repl f = do
  _ <- rep f
  repl f

-- 3
covering
replTill : (String -> Either String String) -> IO ()
replTill f = do
  s <- getLine
  case f s of
    Left  msg => putStrLn msg
    Right msg => do
      _ <- putStrLn msg
      replTill f

-- 4
data Error : Type where
  NotAnInteger    : (value : String) -> Error
  UnknownOperator : (value : String) -> Error
  ParseError      : (input : String) -> Error

dispError : Error -> String
dispError (NotAnInteger v)    = "Not an integer: " ++ v ++ "."
dispError (UnknownOperator v) = "Unknown operator: " ++ v ++ "."
dispError (ParseError v)      = "Invalid expression: " ++ v ++ "."

readInteger : String -> Either Error Integer
readInteger s = maybe (Left $ NotAnInteger s) Right $ parseInteger s

readOperator : String -> Either Error (Integer -> Integer -> Integer)
readOperator "+" = Right (+)
readOperator "*" = Right (*)
readOperator s   = Left (UnknownOperator s)

eval : String -> Either Error Integer
eval s =
  let [x,y,z]  := forget $ split isSpace s | _ => Left (ParseError s)
      Right v1 := readInteger x  | Left e => Left e
      Right op := readOperator y | Left e => Left e
      Right v2 := readInteger z  | Left e => Left e
   in Right $ op v1 v2

covering
exprProg : IO ()
exprProg = replTill prog
  where prog : String -> Either String String
        prog "done" = Left "Goodbye!"
        prog s      = Right . either dispError show $ eval s

-- 5
covering
replWith :  (state      : s)
         -> (next       : s -> String -> Either res s)
         -> (dispState  : s -> String)
         -> (dispResult : res -> s -> String)
         -> IO ()
replWith state next dispState dispResult = do
  _     <- putStrLn (dispState state)
  input <- getLine
  case next state input of
    Left  result => putStrLn (dispResult result state)
    Right state' => replWith state' next dispState dispResult

-- 6
data Abort : Type where
  NoNat : (input : String) -> Abort
  Done  : Abort

printSum : Nat -> String
printSum n =
  "Current sum: " ++ show n ++ "\nPlease enter a natural number:"

printRes : Abort -> Nat -> String
printRes (NoNat input) _ =
  "Not a natural number: " ++ input ++ ". Aborting..."
printRes Done k =
  "Final sum: " ++ show k ++ "\nHave a nice day."

readInput : Nat -> String -> Either Abort Nat
readInput _ "done" = Left Done
readInput n s      = case parseInteger {a = Integer} s of
  Nothing => Left $ NoNat s
  Just v  => if v >= 0 then Right (cast v + n) else Left (NoNat s)

covering
sumProg : IO ()
sumProg = replWith 0 readInput printSum printRes

--------------------------------------------------------------------------------
--          Do Blocks, Desugared
--------------------------------------------------------------------------------

-- 1
ex1a : IO String
ex1a = do
  s1 <- getLine
  s2 <- getLine
  s3 <- getLine
  pure $ s1 ++ reverse s2 ++ s3

ex1aBind : IO String
ex1aBind =
  getLine >>= (\s1 =>
    getLine >>= (\s2 =>
      getLine >>= (\s3 =>
        pure $ s1 ++ reverse s2 ++ s3
      )
    )
  )

ex1aBang : IO String
ex1aBang =
  pure $ !getLine ++ reverse !getLine ++ !getLine

ex1b : Maybe Integer
ex1b = do
  n1 <- parseInteger "12"
  n2 <- parseInteger "300"
  Just $ n1 + n2 * 100

ex1bBind : Maybe Integer
ex1bBind =
  parseInteger "12" >>= (\n1 =>
    parseInteger "300" >>= (\n2 =>
      Just $ n1 + n2 * 100
    )
  )

ex1bBang : Maybe Integer
ex1bBang =
  Just $ !(parseInteger "12") + !(parseInteger "300") * 100

-- 2
data List01 : (nonEmpty : Bool) -> Type -> Type where
  Nil  : List01 False a
  (::) : a -> List01 False a -> List01 ne a

head : List01 True a -> a
head (x :: _) = x

weaken : List01 ne a -> List01 False a
weaken []       = []
weaken (h :: t) = h :: t

map01 : (a -> b) -> List01 ne a -> List01 ne b
map01 _ []       = []
map01 f (x :: y) = f x :: map01 f y

tail : List01 True a -> List01 False a
tail (_ :: t) = weaken t

(++) : List01 ne1 a -> List01 ne2 a -> List01 (ne1 || ne2) a
(++) []       []       = []
(++) []       (h :: t) = h :: t
(++) (h :: t) xs       = h :: weaken (t ++ xs)

concat' : List01 ne1 (List01 ne2 a) -> List01 False a
concat' []       = []
concat' (x :: y) = weaken (x ++ concat' y)

concat :  {ne1, ne2 : _}
       -> List01 ne1 (List01 ne2 a)
       -> List01 (ne1 && ne2) a
concat {ne1 = True}  {ne2 = True}  (x :: y) = x ++ concat' y
concat {ne1 = True}  {ne2 = False} x        = concat' x
concat {ne1 = False} {ne2 = _}     x        = concat' x

namespace List01
  export
  (>>=) :  {ne1, ne2 : _}
        -> List01 ne1 a
        -> (a -> List01 ne2 b)
        -> List01 (ne1 && ne2) b
  as >>= f = concat (map01 f as)

--------------------------------------------------------------------------------
--          Working with Files
--------------------------------------------------------------------------------

-- 1
namespace IOErr
  export
  pure : a -> IO (Either e a)
  pure = pure . Right

  export
  fail : e -> IO (Either e a)
  fail = pure . Left

  export
  lift : IO a -> IO (Either e a)
  lift = map Right

  export
  catch : IO (Either e1 a) -> (e1 -> IO (Either e2 a)) -> IO (Either e2 a)
  catch io f = do
    Left err <- io | Right v => pure v
    f err

  export
  (>>=) : IO (Either e a) -> (a -> IO (Either e b)) -> IO (Either e b)
  io >>= f = Prelude.do
    Right v <- io | Left err => fail err
    f v

  export
  (>>) : IO (Either e ()) -> Lazy (IO (Either e a)) -> IO (Either e a)
  iou >> ioa = Prelude.do
    Right _ <- iou | Left err => fail err
    ioa

covering
countEmpty'' : (path : String) -> IO (Either FileError Nat)
countEmpty'' path = withFile path Read pure (go 0)
  where covering go : Nat -> File -> IO (Either FileError Nat)
        go k file = do
          False <- lift (fEOF file) | True => pure k
          "\n"  <- fGetLine file    | _  => go k file
          go (k + 1) file

-- 2
covering
countWords : (path : String) -> IO (Either FileError Nat)
countWords path = withFile path Read pure (go 0)
  where covering go : Nat -> File -> IO (Either FileError Nat)
        go k file = do
          False <- lift (fEOF file) | True => pure k
          s     <- fGetLine file
          go (k + length (words s)) file

-- 3
covering
withLines :  (path : String)
          -> (accum : s -> String -> s)
          -> (initialState : s)
          -> IO (Either FileError s)
withLines path accum ini = withFile path Read pure (go ini)
  where covering go : s -> File -> IO (Either FileError s)
        go st file = do
          False <- lift (fEOF file) | True => pure st
          line  <- fGetLine file
          go (accum st line) file

covering
countEmpty3 : (path : String) -> IO (Either FileError Nat)
countEmpty3 path = withLines path acc 0
  where acc : Nat -> String -> Nat
        acc k "\n" = k + 1
        acc k _    = k

covering
countWords2 : (path : String) -> IO (Either FileError Nat)
countWords2 path = withLines path (\n,s => n + length (words s)) 0

-- 4
covering
foldLines :  Monoid s
          => (path : String)
          -> (f    : String -> s)
          -> IO (Either FileError s)
foldLines path f = withLines path (\vs => (vs <+>) . f) neutral

-- 5

-- Instead of returning a triple of natural numbers,
-- it is better to make the semantics clear and use
-- a custom record type to store the result.
--
-- In a larger, more-complex application it might be
-- even better to make things truly type safe and
-- define a single field record together with an instance
-- of monoid for each kind of count.
record WC where
  constructor MkWC
  lines : Nat
  words : Nat
  chars : Nat

Semigroup WC where
  MkWC l1 w1 c1 <+> MkWC l2 w2 c2 = MkWC (l1 + l2) (w1 + w2) (c1 + c2)

Monoid WC where
  neutral = MkWC 0 0 0

covering
toWC : String -> WC
toWC s = MkWC 1 (length (words s)) (length s)

covering
wordCount : (path : String) -> IO (Either FileError WC)
wordCount path = foldLines path toWC

-- this is for testing the `wordCount` example.
covering
testWC : (path : String) -> IO ()
testWC path = Prelude.do
  Right (MkWC ls ws cs) <- wordCount path
    | Left err => putStrLn "Error: \{show err}"
  putStrLn "\{show ls} lines, \{show ws} words, \{show cs} characters"


module LazyLazy

import Data.List as L
import Data.List.Lazy

%default total

coef : Nat
coef = 10000

longId : Nat -> Nat
longId n = foldr max n $ L.replicate n n

level3 : LazyList Nat
level3 = iterateN coef (+1) 0 >>= replicate coef . longId >>= replicate coef . longId

main : IO ()
main = putStrLn $ show $ head' level3


module Crypto.AES.Common

import Utils.ConstantTable
import Data.Bits
import Data.DPair
import Data.Fin
import Data.List
import Data.Nat
import Data.Stream
import Data.Vect
import Utils.Misc
import Utils.Bytes

export
matmul : Num a => {p : _} -> (op : Vect m a -> Vect m b -> c) -> Vect n (Vect m a) -> Vect m (Vect p b) -> Vect n (Vect p c)
matmul op [] ys = []
matmul op (x :: xs) ys = map (op x) (transpose ys) :: matmul op xs ys

export
vecxor : Bits a => Vect n a -> Vect n a -> Vect n a
vecxor = zipWith xor

export
matxor : Bits a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)
matxor x y = zipWith vecxor x y

export
sbox : ConstantTable 256 Bits8
sbox = from_vect
  [ 0x63, 0x7c, 0x77, 0x7b, 0xf2, 0x6b, 0x6f, 0xc5, 0x30, 0x01, 0x67, 0x2b, 0xfe, 0xd7, 0xab, 0x76
  , 0xca, 0x82, 0xc9, 0x7d, 0xfa, 0x59, 0x47, 0xf0, 0xad, 0xd4, 0xa2, 0xaf, 0x9c, 0xa4, 0x72, 0xc0
  , 0xb7, 0xfd, 0x93, 0x26, 0x36, 0x3f, 0xf7, 0xcc, 0x34, 0xa5, 0xe5, 0xf1, 0x71, 0xd8, 0x31, 0x15
  , 0x04, 0xc7, 0x23, 0xc3, 0x18, 0x96, 0x05, 0x9a, 0x07, 0x12, 0x80, 0xe2, 0xeb, 0x27, 0xb2, 0x75
  , 0x09, 0x83, 0x2c, 0x1a, 0x1b, 0x6e, 0x5a, 0xa0, 0x52, 0x3b, 0xd6, 0xb3, 0x29, 0xe3, 0x2f, 0x84
  , 0x53, 0xd1, 0x00, 0xed, 0x20, 0xfc, 0xb1, 0x5b, 0x6a, 0xcb, 0xbe, 0x39, 0x4a, 0x4c, 0x58, 0xcf
  , 0xd0, 0xef, 0xaa, 0xfb, 0x43, 0x4d, 0x33, 0x85, 0x45, 0xf9, 0x02, 0x7f, 0x50, 0x3c, 0x9f, 0xa8
  , 0x51, 0xa3, 0x40, 0x8f, 0x92, 0x9d, 0x38, 0xf5, 0xbc, 0xb6, 0xda, 0x21, 0x10, 0xff, 0xf3, 0xd2
  , 0xcd, 0x0c, 0x13, 0xec, 0x5f, 0x97, 0x44, 0x17, 0xc4, 0xa7, 0x7e, 0x3d, 0x64, 0x5d, 0x19, 0x73
  , 0x60, 0x81, 0x4f, 0xdc, 0x22, 0x2a, 0x90, 0x88, 0x46, 0xee, 0xb8, 0x14, 0xde, 0x5e, 0x0b, 0xdb
  , 0xe0, 0x32, 0x3a, 0x0a, 0x49, 0x06, 0x24, 0x5c, 0xc2, 0xd3, 0xac, 0x62, 0x91, 0x95, 0xe4, 0x79
  , 0xe7, 0xc8, 0x37, 0x6d, 0x8d, 0xd5, 0x4e, 0xa9, 0x6c, 0x56, 0xf4, 0xea, 0x65, 0x7a, 0xae, 0x08
  , 0xba, 0x78, 0x25, 0x2e, 0x1c, 0xa6, 0xb4, 0xc6, 0xe8, 0xdd, 0x74, 0x1f, 0x4b, 0xbd, 0x8b, 0x8a
  , 0x70, 0x3e, 0xb5, 0x66, 0x48, 0x03, 0xf6, 0x0e, 0x61, 0x35, 0x57, 0xb9, 0x86, 0xc1, 0x1d, 0x9e
  , 0xe1, 0xf8, 0x98, 0x11, 0x69, 0xd9, 0x8e, 0x94, 0x9b, 0x1e, 0x87, 0xe9, 0xce, 0x55, 0x28, 0xdf
  , 0x8c, 0xa1, 0x89, 0x0d, 0xbf, 0xe6, 0x42, 0x68, 0x41, 0x99, 0x2d, 0x0f, 0xb0, 0x54, 0xbb, 0x16
  ]

export
inv_sbox : ConstantTable 256 Bits8
inv_sbox = from_vect
  [ 0x52, 0x09, 0x6a, 0xd5, 0x30, 0x36, 0xa5, 0x38, 0xbf, 0x40, 0xa3, 0x9e, 0x81, 0xf3, 0xd7, 0xfb
  , 0x7c, 0xe3, 0x39, 0x82, 0x9b, 0x2f, 0xff, 0x87, 0x34, 0x8e, 0x43, 0x44, 0xc4, 0xde, 0xe9, 0xcb
  , 0x54, 0x7b, 0x94, 0x32, 0xa6, 0xc2, 0x23, 0x3d, 0xee, 0x4c, 0x95, 0x0b, 0x42, 0xfa, 0xc3, 0x4e
  , 0x08, 0x2e, 0xa1, 0x66, 0x28, 0xd9, 0x24, 0xb2, 0x76, 0x5b, 0xa2, 0x49, 0x6d, 0x8b, 0xd1, 0x25
  , 0x72, 0xf8, 0xf6, 0x64, 0x86, 0x68, 0x98, 0x16, 0xd4, 0xa4, 0x5c, 0xcc, 0x5d, 0x65, 0xb6, 0x92
  , 0x6c, 0x70, 0x48, 0x50, 0xfd, 0xed, 0xb9, 0xda, 0x5e, 0x15, 0x46, 0x57, 0xa7, 0x8d, 0x9d, 0x84
  , 0x90, 0xd8, 0xab, 0x00, 0x8c, 0xbc, 0xd3, 0x0a, 0xf7, 0xe4, 0x58, 0x05, 0xb8, 0xb3, 0x45, 0x06
  , 0xd0, 0x2c, 0x1e, 0x8f, 0xca, 0x3f, 0x0f, 0x02, 0xc1, 0xaf, 0xbd, 0x03, 0x01, 0x13, 0x8a, 0x6b
  , 0x3a, 0x91, 0x11, 0x41, 0x4f, 0x67, 0xdc, 0xea, 0x97, 0xf2, 0xcf, 0xce, 0xf0, 0xb4, 0xe6, 0x73
  , 0x96, 0xac, 0x74, 0x22, 0xe7, 0xad, 0x35, 0x85, 0xe2, 0xf9, 0x37, 0xe8, 0x1c, 0x75, 0xdf, 0x6e
  , 0x47, 0xf1, 0x1a, 0x71, 0x1d, 0x29, 0xc5, 0x89, 0x6f, 0xb7, 0x62, 0x0e, 0xaa, 0x18, 0xbe, 0x1b
  , 0xfc, 0x56, 0x3e, 0x4b, 0xc6, 0xd2, 0x79, 0x20, 0x9a, 0xdb, 0xc0, 0xfe, 0x78, 0xcd, 0x5a, 0xf4
  , 0x1f, 0xdd, 0xa8, 0x33, 0x88, 0x07, 0xc7, 0x31, 0xb1, 0x12, 0x10, 0x59, 0x27, 0x80, 0xec, 0x5f
  , 0x60, 0x51, 0x7f, 0xa9, 0x19, 0xb5, 0x4a, 0x0d, 0x2d, 0xe5, 0x7a, 0x9f, 0x93, 0xc9, 0x9c, 0xef
  , 0xa0, 0xe0, 0x3b, 0x4d, 0xae, 0x2a, 0xf5, 0xb0, 0xc8, 0xeb, 0xbb, 0x3c, 0x83, 0x53, 0x99, 0x61
  , 0x17, 0x2b, 0x04, 0x7e, 0xba, 0x77, 0xd6, 0x26, 0xe1, 0x69, 0x14, 0x63, 0x55, 0x21, 0x0c, 0x7d
  ]

export
sub_byte : Bits8 -> Bits8
sub_byte x = index_bits8 x sbox

export
inv_sub_byte : Bits8 -> Bits8
inv_sub_byte x = index_bits8 x inv_sbox

export
sub_word : Vect m Bits8 -> Vect m Bits8
sub_word = map sub_byte

export
inv_sub_word : Vect m Bits8 -> Vect m Bits8
inv_sub_word = map inv_sub_byte

export
sub_bytes : Vect n (Vect m Bits8) -> Vect n (Vect m Bits8)
sub_bytes = map sub_word

export
inv_sub_bytes : Vect n (Vect m Bits8) -> Vect n (Vect m Bits8)
inv_sub_bytes = map inv_sub_word

export
rot_word : {n : Nat} -> Nat -> Vect (S n) a -> Vect (S n) a
rot_word k = take (S n) . drop k . cycle

export
inv_rot_word : {n : Nat} -> Nat -> Vect (S n) a -> Vect (S n) a
inv_rot_word k = take (S n) . drop (n * k) . cycle

export
rcons : Stream Bits8
rcons = go 1
  where
  go : Bits8 -> Stream Bits8
  go x = x :: go ((if x < 0x80 then id else xor (0x1B)) $ 2 * x)

export
expand_key' : {n_k, n_b : _} -> {auto 0 ok : NonZero n_b} -> Fin n_k -> (rcs : Stream Bits8) -> (prev_block : Vect n_k (Vect n_b Bits8)) -> Stream (Vect n_b Bits8)
expand_key' {n_b = S n_b'} counter (rc :: rcs) (x :: xs) =
  let
    y = last (x :: xs)
  in
    case counter of
      FZ => let z = (vecxor (rc :: replicate _ 0) $ vecxor x $ sub_word $ rot_word 1 $ y) in z :: expand_key' Data.Fin.last rcs (snoc xs z)
      (FS counter') =>
        let
          z = vecxor x $ case isLT 6 n_k of
            Yes wit => if finToNat (FS counter') == 4 then sub_word y else y
            No contra => y
        in
          z :: expand_key' (weaken counter') (rc :: rcs) (snoc xs z)

export
expand_key : {n_k, n_b : _} -> {auto 0 ok : NonZero n_b} -> {auto 0 ok2 : NonZero n_k} -> Vect n_k (Vect n_b Bits8) -> Stream (Vect n_b Bits8)
expand_key {n_k = S n_k'} k = expand_key' FZ rcons k

public export
data Mode : Type where
  AES128 : Mode
  AES192 : Mode
  AES256 : Mode

public export
get_n_k : Mode -> Nat
get_n_k AES128 = 4
get_n_k AES192 = 6
get_n_k AES256 = 8

public export
n_k_never_Z : (mode : _) -> NonZero (get_n_k mode)
n_k_never_Z AES128 = SIsNonZero
n_k_never_Z AES192 = SIsNonZero
n_k_never_Z AES256 = SIsNonZero

public export
get_main_rounds : Mode -> Nat
get_main_rounds AES128 = 9
get_main_rounds AES192 = 11
get_main_rounds AES256 = 13


> foo : Nat -> Nat
> foo x = ?foo_rhs
>
> bar : Nat -> Nat
> bar x = plus x ?bar_rhs
>
> -- Rest of file


import DataStore
import DescribeList
import DescribeList2
import IsSuffix
import MergeSort
import MergeSortView
import Reverse
import ReverseSnoc
import Shape
import Shape_abs
import SnocList
import TestStore


import AppendVec
import CheckEqDec
import CheckEqMaybe
import EqNat
import ExactLength
import ExactLengthDec
import ReverseVec
import TCVects
import Void


module Data.Crypto.MAC

import Data.Bits

%default total
%access public export

interface Signer s (blockLength : Nat) (outputLength : Nat) | s where
  signMessage : s -> List (Bits blockLength) -> Bits outputLength

interface Verifier v (blockLength : Nat) (outputLength : Nat) | v where
  verifyMessage : v -> List (Bits blockLength) -> Bits n -> Bool

interface (Signer m b o, Verifier m b o) => MAC m (b : Nat) (o : Nat) | m where
  -- TODO: This default implementation _should_ work.
  -- implementation Verifier m b o where
  --   verifyMessage key message digest = digest == signMessage key message


module Lambda

%default total

data Ty = TyFunc Ty Ty | TyNat

data Context = Empty | Extend Context Ty

data Contains : Context -> Ty -> Type where
  Here : Contains (Extend g ty) ty
  There : (rest :  Contains g ty)
       -> Contains (Extend g not_ty) ty

data Term : Context -> Ty -> Type where
  Var : (idx : Contains g ty)
     -> Term g ty

  Func : (body : Term (Extend g tyA) tyB)
      -> Term g (TyFunc tyA tyB)

  App : (func : Term g (TyFunc tyA tyB))
     -> (var  : Term g tyA)
     -> Term g tyB

  Zero : Term g TyNat

  Next : (inner : Term g TyNat)
      -> Term g TyNat

  Case : (scrutinee : Term g TyNat)
      -> (zero : Term g tyA)
      -> (next : Term (Extend g TyNat) tyA)
      -> Term g tyA

  Plus : Term g TyNat
      -> Term g TyNat
      -> Term g TyNat

  Rec : (body : Term (Extend g tyA) tyA)
    -> Term g tyA

term : Term Empty
            (TyFunc TyNat -- (Var Here) -
                    (TyFunc TyNat -- (Var (There Here)) -
                            (TyFunc TyNat -- (Var (There (There Here))) -
                                    (TyFunc TyNat -- (Var (There (There (There Here)))) -
                                           (TyFunc TyNat -- (Var (There (There (There (There Here))))) -
                                                   (TyFunc TyNat -- (Var (There (There (There (There (There Here)))))) -
                                                           (TyFunc TyNat -- (Var (There (There (There (There (There (There Here)))))))
                                                                   TyNat
                                                                   )
                                                                   )
                                                                   )
                                                                   )
                                                                   )
                                                                   )
                                                                   )
term =
  Func
      (Func
           (Func
                (Func
                     (Func
                          (Func
                               (Func
                                    (Func (Plus (Var Here)
                                                (Plus (Var (There Here))
                                                      (Plus (Var (There (There Here)))
                                                            (Plus (Var (There (There (There Here))))
                                                                  (Plus (Var (There (There (There (There Here)))))
                                                                        (Plus  (Var (There (There (There (There (There Here))))))
                                                                               (Var (There (There (There (There (There (There Here)))))))
                                                                        )
                                                                  )
                                                            )
                                                      )
                                                 )
                                          )
                                    )
                               )
                          )
                     )
                )
            )
       )


%default total

--changing codata to dat would make "ones" non-total
codata Stream' : Type -> Type where
  (::) : (e : a) -> Stream' a -> Stream' a

ones : Stream' Nat
ones = 1 :: ones


module Hoare

-- Based on http://eprints.nottingham.ac.uk/10779/1/Thesis.pdf

Pre : Type -> Type
Pre s = s -> Type

Post : Type -> Type -> Type
Post s a = s -> a -> s -> Type

HoareState : (s : Type) -> Pre s -> (a : Type) -> Post s a -> Type
HoareState s pre a post = (d : DPair s pre) -> DPair (a, s) (\(x, f) => post (fst d) x f)

return : {a : Type} -> (x : a) -> HoareState s (\_ => ()) a (\i, y, f => (i = f, x = y))
return x (st ** ()) = ((x, st) ** (Refl, Refl))

(>>=) : {p1 : Pre s} -> {q1 : Post s a} -> {p2 : a -> Pre s} -> {q2 : a -> Post s b} ->
        HoareState s p1 a q1 ->
        ((x : a) -> HoareState s (p2 x) b (q2 x)) ->
        HoareState s (\s1 => (p1 s1, ((x : a) -> (s2 : s) -> q1 s1 x s2 -> p2 x s2))) b
                     (\s1, x, s3 => DPair (a, s) (\(y,s2) => (q1 s1 y s2, q2 y s2 x s3)))
(>>=) c1 c2 (s1 ** (s1p1, f)) = let ((x, s2) ** p) = (c1 (s1 ** s1p1)) in
                                let ((y, s3) ** q) = c2 x (s2 ** (f x s2 p)) in
                                ((y, s3) ** ((x, s2) ** (p, q)))

get : HoareState s (\_ => ()) s (\i, x, f => (i = f, x = i))
get (st ** ()) = ((st, st) ** (Refl, Refl))

put : (st : s) -> HoareState s (\_ => ()) () (\i, x, f => f = st)
put st _ = (((), st) ** Refl)


{-
0.42
1.68
1.34
0.34
-}
module Main

main : IO ()
main =
  traverse_
    (\op => printLn $ 0.84 `op` 0.5)
    [(*), (/), (+), (-)]


> module Lit
>
> %default total

a > b

a < b

> data V a = Empty | Extend a (V a)

> isCons : V a -> Bool
> isCons Empty = False
> isCons (Extend _ _) = True

< namespace Hidden
<   data U a = Empty | Extend a (U a)


{-
%builtins output pedersen

from starkware.cairo.common.cairo_builtins import HashBuiltin
from starkware.cairo.common.hash import hash2
from starkware.cairo.common.serialize import serialize_word

func main{output_ptr : felt*, pedersen_ptr : HashBuiltin*}():
    let (res) = hash2{hash_ptr=pedersen_ptr}(1,2)
    serialize_word(res + 1)
    return ()
end
-}

module Main

import Cairo

%noinline
main : Cairo ()
main =
    output (1 + (pedersenHash 1 2))


module Solutions.Folds

import Data.Maybe
import Data.SnocList
import Data.Vect

%default total

--------------------------------------------------------------------------------
--          Recursion
--------------------------------------------------------------------------------

-- 1

anyList : (a -> Bool) -> List a -> Bool
anyList p []        = False
anyList p (x :: xs) = case p x of
  False => anyList p xs
  True  => True

allList : (a -> Bool) -> List a -> Bool
allList p []        = True
allList p (x :: xs) = case p x of
  True  => allList p xs
  False => False

-- 2

findList : (a -> Bool) -> List a -> Maybe a
findList f []        = Nothing
findList f (x :: xs) = if f x then Just x else findList f xs

-- 3

collectList : (a -> Maybe b) -> List a -> Maybe b
collectList f []        = Nothing
collectList f (x :: xs) = case f x of
  Just vb => Just vb
  Nothing => collectList f xs

-- Note utility function `Data.Maybe.toMaybe` in the implementation
lookupList : Eq a => a -> List (a,b) -> Maybe b
lookupList va = collectList (\(k,v) => toMaybe (k == va) v)

-- 4

mapTR : (a -> b) -> List a -> List b
mapTR f = go Lin
  where go : SnocList b -> List a -> List b
        go sx []        = sx <>> Nil
        go sx (x :: xs) = go (sx :< f x) xs

-- 5

filterTR : (a -> Bool) -> List a -> List a
filterTR f = go Lin
  where go : SnocList a -> List a -> List a
        go sx []        = sx <>> Nil
        go sx (x :: xs) = if f x then go (sx :< x) xs else go sx xs

-- 6

mapMaybeTR : (a -> Maybe b) -> List a -> List b
mapMaybeTR f = go Lin
  where go : SnocList b -> List a -> List b
        go sx []        = sx <>> Nil
        go sx (x :: xs) = case f x of
          Just vb => go (sx :< vb) xs
          Nothing => go sx xs

catMaybesTR : List (Maybe a) -> List a
catMaybesTR = mapMaybeTR id

-- 7

concatTR : List a -> List a -> List a
concatTR xs ys = (Lin <>< xs) <>> ys

-- 8

bindTR : List a -> (a -> List b) -> List b
bindTR xs f = go Lin xs
  where go : SnocList b -> List a -> List b
        go sx []        = sx <>> Nil
        go sx (x :: xs) = go (sx <>< f x) xs

joinTR : List (List a) -> List a
joinTR = go Lin
  where go : SnocList a -> List (List a) -> List a
        go sx []        = sx <>> Nil
        go sx (x :: xs) = go (sx <>< x) xs

--------------------------------------------------------------------------------
--          A few Notes on Totality Checking
--------------------------------------------------------------------------------

record Tree a where
  constructor Node
  value  : a
  forest : List (Tree a)

Forest : Type -> Type
Forest = List . Tree

example : Tree Bits8
example = Node 0 [Node 1 [], Node 2 [Node 3 [], Node 4 [Node 5 []]]]

mutual
  treeSize : Tree a -> Nat
  treeSize (Node _ forest) = S $ forestSize forest

  forestSize : Forest a -> Nat
  forestSize []        = 0
  forestSize (x :: xs) = treeSize x + forestSize xs

-- 1

mutual
  treeDepth : Tree a -> Nat
  treeDepth (Node _ forest) = S $ forestDepth forest

  forestDepth : Forest a -> Nat
  forestDepth []        = 0
  forestDepth (x :: xs) = max (treeDepth x) (forestDepth xs)

-- 2

-- It's often easier to write complex interface implementations
-- via a utility function.
--
-- Of course, we could also use a `mutual` block as with
-- `treeSize` and `forestSize` here.
treeEq : Eq a => Tree a -> Tree a -> Bool
treeEq (Node v1 f1) (Node v2 f2) = v1 == v2 && go f1 f2
  where go : Forest a -> Forest a -> Bool
        go []        []        = True
        go (x :: xs) (y :: ys) = treeEq x y && go xs ys
        go _         _         = False

Eq a => Eq (Tree a) where (==) = treeEq

-- 3

treeMap : (a -> b) -> Tree a -> Tree b
treeMap f (Node value forest) = Node (f value) (go forest)
  where go : Forest a -> Forest b
        go []        = []
        go (x :: xs) = treeMap f x :: go xs

Functor Tree where map = treeMap

-- 4

treeShow : Show a => Prec -> Tree a -> String
treeShow p (Node value forest) =
  showCon p "Node" $ showArg value ++ case forest of
    []      => " []"
    x :: xs => " [" ++ treeShow Open x ++ go xs ++ "]"

  where go : Forest a -> String
        go []        = ""
        go (y :: ys) = ", " ++ treeShow Open y ++ go ys

Show a => Show (Tree a) where showPrec = treeShow

-- 5

mutual
  treeToVect : (tr : Tree a) -> Vect (treeSize tr) a
  treeToVect (Node value forest) = value :: forestToVect forest

  forestToVect : (f : Forest a) -> Vect (forestSize f) a
  forestToVect []        = []
  forestToVect (x :: xs) = treeToVect x ++ forestToVect xs

--------------------------------------------------------------------------------
--          Interface Foldable
--------------------------------------------------------------------------------

-- 1

data Crud : (i : Type) -> (a : Type) -> Type where
  Create : (value : a) -> Crud i a
  Update : (id : i) -> (value : a) -> Crud i a
  Read   : (id : i) -> Crud i a
  Delete : (id : i) -> Crud i a

Foldable (Crud i) where
  foldr acc st (Create value)   = acc value st
  foldr acc st (Update _ value) = acc value st
  foldr _   st (Read _)         = st
  foldr _   st (Delete _)       = st

  foldl acc st (Create value)   = acc st value
  foldl acc st (Update _ value) = acc st value
  foldl _   st (Read _)         = st
  foldl _   st (Delete _)       = st

  null (Create _)   = False
  null (Update _ _) = False
  null (Read _)     = True
  null (Delete _)   = True

  foldMap f (Create value)   = f value
  foldMap f (Update _ value) = f value
  foldMap _ (Read _)         = neutral
  foldMap _ (Delete _)       = neutral

  foldlM acc st (Create value)   = acc st value
  foldlM acc st (Update _ value) = acc st value
  foldlM _   st (Read _)         = pure st
  foldlM _   st (Delete _)       = pure st

  toList (Create v)   = [v]
  toList (Update _ v) = [v]
  toList (Read _)     = []
  toList (Delete _)   = []

-- 2

data Response : (e, i, a : Type) -> Type where
  Created : (id : i) -> (value : a) -> Response e i a
  Updated : (id : i) -> (value : a) -> Response e i a
  Found   : (values : List a) -> Response e i a
  Deleted : (id : i) -> Response e i a
  Error   : (err : e) -> Response e i a

Foldable (Response e i) where
  foldr acc st (Created _ value) = acc value st
  foldr acc st (Updated _ value) = acc value st
  foldr acc st (Found values)    = foldr acc st values
  foldr _   st (Deleted _)       = st
  foldr _   st (Error _)         = st

  foldl acc st (Created _ value) = acc st value
  foldl acc st (Updated _ value) = acc st value
  foldl acc st (Found values)    = foldl acc st values
  foldl _   st (Deleted _)       = st
  foldl _   st (Error _)         = st

  null (Created _ _)     = False
  null (Updated _ _)     = False
  null (Found values)    = null values
  null (Deleted _)       = True
  null (Error _)         = True

  foldMap f (Created _ value) = f value
  foldMap f (Updated _ value) = f value
  foldMap f (Found values)    = foldMap f values
  foldMap f (Deleted _)       = neutral
  foldMap f (Error _)         = neutral

  toList (Created _ value) = [value]
  toList (Updated _ value) = [value]
  toList (Found values)    = values
  toList (Deleted _)       = []
  toList (Error _)         = []

  foldlM acc st (Created _ value) = acc st value
  foldlM acc st (Updated _ value) = acc st value
  foldlM acc st (Found values)    = foldlM acc st values
  foldlM _   st (Deleted _)       = pure st
  foldlM _   st (Error _)         = pure st

-- 3

data List01 : (nonEmpty : Bool) -> Type -> Type where
  Nil  : List01 False a
  (::) : a -> List01 False a -> List01 ne a

list01ToList : List01 ne a -> List a
list01ToList = go Lin
  where go : SnocList a -> List01 ne' a -> List a
        go sx []        = sx <>> Nil
        go sx (x :: xs) = go (sx :< x) xs

list01FoldMap : Monoid m => (a -> m) -> List01 ne a -> m
list01FoldMap f = go neutral
  where go : m -> List01 ne' a -> m
        go vm []        = vm
        go vm (x :: xs) = go (vm <+> f x) xs

Foldable (List01 ne) where
  foldr acc st []        = st
  foldr acc st (x :: xs) = acc x (foldr acc st xs)

  foldl acc st []        = st
  foldl acc st (x :: xs) = foldl acc (acc st x) xs

  null []       = True
  null (_ :: _) = False

  toList = list01ToList

  foldMap = list01FoldMap

  foldlM _ st []        = pure st
  foldlM f st (x :: xs) = f st x >>= \st' => foldlM f st' xs

-- 4

mutual
  foldrTree : (el -> st -> st) -> st -> Tree el -> st
  foldrTree f v (Node value forest) = f value (foldrForest f v forest)

  foldrForest : (el -> st -> st) -> st -> Forest el -> st
  foldrForest _ v []        = v
  foldrForest f v (x :: xs) = foldrTree f (foldrForest f v xs) x

mutual
  foldlTree : (st -> el -> st) -> st -> Tree el -> st
  foldlTree f v (Node value forest) = foldlForest f (f v value) forest

  foldlForest : (st -> el -> st) -> st -> Forest el -> st
  foldlForest _ v []        = v
  foldlForest f v (x :: xs) = foldlForest f (foldlTree f v x) xs

mutual
  foldMapTree : Monoid m => (el -> m) -> Tree el -> m
  foldMapTree f (Node value forest) = f value <+> foldMapForest f forest

  foldMapForest : Monoid m => (el -> m) -> Forest el -> m
  foldMapForest _ []        = neutral
  foldMapForest f (x :: xs) = foldMapTree f x <+> foldMapForest f xs

mutual
  toListTree : Tree el -> List el
  toListTree (Node value forest) = value :: toListForest forest

  toListForest : Forest el -> List el
  toListForest []        = []
  toListForest (x :: xs) = toListTree x ++ toListForest xs

mutual
  foldlMTree : Monad m => (st -> el -> m st) -> st -> Tree el -> m st
  foldlMTree f v (Node value forest) =
    f v value >>= \v' => foldlMForest f v' forest

  foldlMForest : Monad m => (st -> el -> m st) -> st -> Forest el -> m st
  foldlMForest _ v []        = pure v
  foldlMForest f v (x :: xs) =
    foldlMTree f v x >>= \v' => foldlMForest f v' xs

Foldable Tree where
  foldr   = foldrTree
  foldl   = foldlTree
  foldMap = foldMapTree
  foldlM  = foldlMTree
  null _  = False
  toList  = toListTree

-- 5

record Comp (f,g : Type -> Type) (a : Type) where
  constructor MkComp
  unComp  : f (g a)

Foldable f => Foldable g => Foldable (Comp f g) where
  foldr f st (MkComp v)  = foldr (flip $ foldr f) st v
  foldl f st (MkComp v)  = foldl (foldl f) st v
  foldMap f (MkComp v)   = foldMap (foldMap f) v
  foldlM f st (MkComp v) = foldlM (foldlM f) st v
  toList (MkComp v)      = foldMap toList v
  null (MkComp v)        = all null v

record Product (f,g : Type -> Type) (a : Type) where
  constructor MkProduct
  fst : f a
  snd : g a

Foldable f => Foldable g => Foldable (Product f g) where
  foldr f st (MkProduct v w)  = foldr f (foldr f st w) v
  foldl f st (MkProduct v w)  = foldl f (foldl f st v) w
  foldMap f (MkProduct v w)   = foldMap f v <+> foldMap f w
  toList  (MkProduct v w)     = toList v ++ toList w
  null (MkProduct v w)        = null v && null w
  foldlM f st (MkProduct v w) = foldlM f st v >>= \st' => foldlM f st' w

--------------------------------------------------------------------------------
--          Tests
--------------------------------------------------------------------------------

iterateTR : Nat -> (a -> a) -> a -> List a
iterateTR k f = go k Lin
  where go : Nat -> SnocList a -> a -> List a
        go 0     sx _ = sx <>> Nil
        go (S k) sx x = go k (sx :< x) (f x)

values : List Integer
values = iterateTR 100000 (+1) 0

main : IO ()
main = do
  printLn . length $ mapTR (*2)  values
  printLn . length $ filterTR (\n => n `mod` 2 == 0)  values
  printLn . length $ mapMaybeTR (\n => toMaybe (n `mod` 2 == 1) "foo")  values
  printLn . length $ concatTR values values
  printLn . length $ bindTR [1..500] (\n => iterateTR n (+1) n)


module Main

import Effekt.CpsStaged
import Effekt.IteratedUnstaged
import Effekt.IteratedStaged
import Effekt.AvoidEta

fail : STM (String :: rs) a
fail = shift0 (\k => do
  pure (Str "no"))

flip : STM (r :: rs) Bool
flip = shift0 (\k => do
  resume k Tru
  resume k Fls)

delimitFail : STM rs String
delimitFail {rs} = do
  a <- reset0 fail
  pure {rs} ((Cat (Str "Answer was: ") a))

emit : Exp a -> STM (List a :: rs) ()
emit a = shift0 (\k => do
  as <- resume k Uni
  pure ((Con a as)))

collect : STM (List a :: rs) b -> STM rs (List a)
collect {rs} {a} m = reset0 {a=List a} {rs} (
  (>>=) {rs=List a :: rs} m (\u => pure {rs=List a :: rs} Emp))

choice : Exp Int -> STM (String :: rs) Int
choice {rs} = letrec (\recurse => \n => do
  ifthenelse ((Sma n (Lit 1)))
    fail
    (do
      b <- flip
      ifthenelse b
        (pure {rs=String::rs} n)
        (recurse ((Sub n (Lit 1))))))

triple : Exp Int -> Exp Int -> STM (String :: rs) (Int, Int, Int)
triple {rs} n s = do
  i  <- choice n
  j  <- choice ((Sub i (Lit 1)))
  k  <- choice ((Sub j (Lit 1)))
  ifthenelse ((Equ ((Add i ((Add j k)))) s))
    (pure {rs=String::rs} (Tri i j k))
    fail

emitTriples : STM (String :: List (Int, Int, Int) :: rs) String
emitTriples {rs} =
  (>>=) {rs=(String :: List (Int, Int, Int) :: rs)} (triple (Lit 9) (Lit 15))  (\ijk =>
  (>>=) {rs=(String :: List (Int, Int, Int) :: rs)} (lift (emit ijk)) (\u =>
  pure {rs=(String :: List (Int, Int, Int) :: rs)} (Str "done")))

emittedTriples : STM [] (List (Int, Int, Int))
emittedTriples = collect {rs=[]} (reset0 (emitTriples {rs=[]}))

first : Exp a -> STM (Maybe a :: rs) ()
first {rs} a = shift0 (\k => do
  pure {rs} ((Jus a)))

firstTriples : STM (String :: Maybe (Int, Int, Int) :: rs) String
firstTriples {rs} =
  (>>=) {rs=(String :: Maybe (Int, Int, Int) :: rs)} (triple (Lit 9) (Lit 15))  (\ijk =>
  (>>=) {rs=(String :: Maybe (Int, Int, Int) :: rs)} (lift (first ijk)) (\u =>
  pure {rs=(String :: Maybe (Int, Int, Int) :: rs)} (Str "done")))
firstTriple : STM [] (Maybe (Int, Int, Int))
firstTriple = reset0 {a=Maybe (Int,Int,Int)} {rs=[]} (
  (>>=) {rs=[Maybe (Int,Int,Int)]} (reset0 (firstTriples {rs=[]})) (\u =>
  pure {rs=[Maybe (Int,Int,Int)]} Noh))

program : Exp (Stm [String,List Int] String -> Stm [] (List Int))
program = Lam (\m =>
  reify (collect {rs=[]} {a=Int} {b=String} (reset0 {rs=[List Int]} (
    reflect {a=String} {rs=[String,List Int]} m))))

main : IO ()
main = putStrLn (pretty 0 emittedTriples)

  -- generated_source : List (Int, Int, Int)
  -- generated_source =
  -- ((((let f0 x1 = (\x2 => (\x3 =>
  --    (if (x1 < 1)
  --      then (x3 "no")
  --      else ((x2 x1) (\x4 => (((f0 (x1 - 1)) x2) x3)))))) in f0) 9) (\x0 => (\x1 =>
  -- ((((let f2 x3 = (\x4 => (\x5 =>
  --    (if (x3 < 1)
  --      then (x5 "no")
  --      else ((x4 x3) (\x6 => (((f2 (x3 - 1)) x4) x5)))))) in f2) (x0 - 1)) (\x2 => (\x3 =>
  -- ((((let f4 x5 = (\x6 => (\x7 =>
  --    (if (x5 < 1)
  --      then (x7 "no")
  --      else ((x6 x5) (\x8 => (((f4 (x5 - 1)) x6) x7)))))) in f4) (x2 - 1)) (\x4 => (\x5 =>
  --        (if ((x0 + (x2 + x4)) == 15)
  --          then ((x0, x2, x4) :: (x5 "done"))
  --          else (x5 "no"))))) x3)))) x1)))) (\x0 => []))


module Main

import Control.Isomorphism
import Regex.Type

infixl 7 :.:
infixl 6 :|:
infixl 6 :&:

%default total

mutual
  ||| The type of witnesses to a string matching `r+` for some regular
  ||| expression `r`, where `+` is the Kleene plus operator.
  data LPlus : List tok -> Regex tok -> Type where
    SP : (DecEq tok)
         => Matches {tok} s r
         -> LPlus {tok} s r
    CP : (DecEq tok)
         => (s1 ++ s2 = s)
         -> Matches {tok} s1 r
         -> LPlus {tok} s2 r
         -> LPlus {tok} s r

  ||| Returns a type of witnesses to the fact that a given regular expression
  ||| is matched by a given list of tokens.
  Matches : (DecEq tok) => List tok -> Regex tok -> Type
  Matches {tok} = Lang
    where
      Lang : List tok -> Regex tok -> Type
      Lang _  Ø         = Void
      Lang [] Ɛ         = ()
      Lang _  Ɛ         = Void
      Lang x  (Tok t)   = (x = [t])
      Lang x  (Comp r)  = Lang x r -> Void
      Lang [] (Star r)  = ()
      Lang x  (Star r)  = LPlus x r
      Lang x  (r :|: s) = Either (Lang x r) (Lang x s)
      Lang x  (r :&: s) = (Lang x r, Lang x s)
      Lang x  (r :.: s) = (p, q : List tok) -> (p ++ q = x, Lang p r, Lang q s)

||| A proof that the given regular expressions are equivalent.
Equiv : (DecEq tok) => Regex tok -> Regex tok -> Type
Equiv {tok} r s = (str : List tok) -> (Matches str r, Matches str s)

||| If the given regular expression contains the empty string, the result is Ɛ.
||| Otherwise, the result is Ø.
nullable : Regex tok -> Regex tok
nullable = \x => if go x then Ɛ else Ø
  where
    go : Regex t -> Bool
    go Ø         = False
    go Ɛ         = True
    go (Tok t)   = False
    go (Comp r)  = not (go r)
    go (Star r)  = True
    go (r :|: s) = go r || go s
    go (r :&: s) = go r && go s
    go (r :.: s) = go r && go s

||| A type-level witness to the claim that a given regular expression
||| is nullable
Nullable : (DecEq tok) => Regex tok -> Type
Nullable r = Matches [] r

absurdIso : {ty : Type}
            -> (DecEq ty)
            => (a : ty) -> (b : ty)
            -> (dec : Dec (a = b))
            -> (decAsBool dec = False)
            -> Iso Void (a = b)
absurdIso a b (Yes _)     Refl impossible
absurdIso a b (No contra) Refl = MkIso absurd contra
                                 (\x => absurd (contra x))
                                 (\x => absurd x)

||| FIXME: doc
nullableWorks : (DecEq tok, DecEq (Regex tok)) => (r : Regex tok)
                -> Iso (Nullable r) (nullable r = Ɛ)
nullableWorks Ø = absurdIso Ø Ɛ (decEq Ø Ɛ) ?fixme
--   where
--     fixme : (DecEq t) => (a : t) -> (b : t) -> {prf : (decEq a b = No contra)}
--             -> (a = b) -> Void
--     fixme = ?help
nullableWorks owise = ?fixme_nullableWorks_owise
-- nullableWorks Ø         = ?fixme71_1
-- nullableWorks Ɛ         = ?fixme71_2
-- nullableWorks (Tok x)   = ?fixme71_3
-- nullableWorks (Comp x)  = ?fixme71_4
-- nullableWorks (Star x)  = ?fixme71_5
-- nullableWorks (x :|: y) = ?fixme71_6
-- nullableWorks (x :&: y) = ?fixme71_7
-- nullableWorks (x :.: y) = ?fixme71_8

||| The Brzozowski derivative of a regular expression
deriv : (Eq tok) => tok -> Regex tok -> Regex tok
deriv a Ø         = Ø
deriv a Ɛ         = Ø
deriv a (Tok t)   = if t == a then Ɛ else Ø
deriv a (Comp r)  = Comp (deriv a r)
deriv a (Star r)  = deriv a r :.: Star r
deriv a (r :|: s) = deriv a r :|: deriv a s
deriv a (r :&: s) = deriv a r :&: deriv a s
deriv a (r :.: s) = let r' = deriv a r
                        s' = deriv a s
                    in (r' :.: s) :|: (nullable r :.: s')

||| The Brzozowski derivative with respect to strings
derivative : (Eq tok) => List tok -> Regex tok -> Regex tok
derivative []        r = r
derivative (a :: as) r = deriv a (derivative as r)

||| FIXME: doc
derivativeWorks : (DecEq tok, Eq tok)
                  => (str : List tok) -> (r : Regex tok)
                  -> Iso (Matches str r) (Matches [] (derivative str r))
derivativeWorks = ?fixme_derivativeWorks
-- derivativeWorks str Ø         = ?fixme72_1
-- derivativeWorks str Ɛ         = ?fixme72_2
-- derivativeWorks str (Tok x)   = ?fixme72_3
-- derivativeWorks str (Comp x)  = ?fixme72_4
-- derivativeWorks str (Star x)  = ?fixme72_5
-- derivativeWorks str (x :|: y) = ?fixme72_6
-- derivativeWorks str (x :&: y) = ?fixme72_7
-- derivativeWorks str (x :.: y) = ?fixme72_8

main : IO ()
main = print (decAsBool (regexDecEq Bool (Ø {tok=Bool}) (Ɛ {tok=Bool})))


module Main

import System

printLength : IO ()
printLength = getLine >>= \input => let len = length input in putStrLn $ show len

printLengthDo : IO ()
printLengthDo = do
              input <- getLine
              let len = length input
              putStrLn $ show len

printLonger : IO ()
printLonger = putStrLn "Enter the first string:" >>= \_ =>
              getLine >>= \inp1 =>
              putStrLn "Enter the second string:" >>= \_ =>
              getLine >>= \inp2 =>
              let len1 = length inp1 in
              let len2 = length inp2 in
              if len1 > len2 then
                 putStr ("The length of the longer string is " ++ (show len1) ++ "\n")
              else
                 putStr ("The length of the longer string is " ++ (show len2) ++ "\n")

printLongerDo : IO ()
printLongerDo = do
            putStrLn "Enter the first string:"
            inp1 <- getLine
            putStrLn "Enter the second string:"
            inp2 <- getLine
            let len1 = length inp1
            let len2 = length inp2
            if len1 > len2 then
               putStr ("The length of the longer string is " ++ (show len1) ++ "\n")
            else
               putStr ("The length of the longer string is " ++ (show len2) ++ "\n")

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

readPair : IO (String, String)
readPair = do
         str1 <- getLine
         str2 <- getLine
         pure (str1, str2)

usePair : IO ()
usePair = do
          (str1, str2) <- readPair
          putStrLn ("You entered " ++ str1 ++ " and " ++ str2)

-- We can directly pattern match on values obtained by executing some action
-- Alternative case matches can be provided after the vertical bar like below
readNumbers : IO (Maybe (Nat, Nat))
readNumbers = do
              Just num1_ok <- readNumber | Nothing => pure Nothing
              Just num2_ok <- readNumber | Nothing => pure Nothing
              pure (Just (num1_ok, num2_ok))

guess : (target : Nat) -> (guesses : Nat) -> IO ()
guess target guesses = do
             putStrLn "Guess the number:"
             Just no <- readNumber
           | Nothing => do putStrLn "The entered input is invalid. Please try again!"
                           guess target guesses
             let newGuesses = guesses + 1
             putStrLn ("You have guessed " ++ (show newGuesses) ++ " times")
             case compare no target of
                  LT => do putStrLn "The number you have entered is too low. Please try again!"
                           guess target newGuesses
                  GT => do putStrLn "The number you have entered is too high. Please try again!"
                           guess target newGuesses
                  EQ => putStrLn "The number you have entered is correct. Congrats!"

myrepl : (prompt : String) -> (onInput : String -> String) -> IO ()
myrepl prompt onInput = do
                      putStrLn prompt
                      input <- getLine
                      putStrLn $ onInput input
                      myrepl prompt onInput

myreplWith : (state : a) -> (prompt : String) ->
             (onInput : a -> String -> Maybe (String, a)) -> IO ()
myreplWith state prompt onInput =
           do putStrLn prompt
              input <- getLine
              case onInput state input of
                   Just (output, newState)
                        => do putStrLn output
                              myreplWith newState prompt onInput
                   Nothing => putStrLn ""

main : IO ()
main = do
     rint <- time
     let no = fromInteger (rint) `modNat` 100
     guess no 0


module Data.Iterable

import Data.List1
import Data.SnocList

import public Control.MonadRec

--------------------------------------------------------------------------------
--          Iterable
--------------------------------------------------------------------------------

refl : {k : Nat} -> LTE k k
refl = reflexive {x = k}

public export
interface Iterable container element | container where
  iterM :  MonadRec m
        => (accum : element -> st -> m st)
        -> (done  : st -> res)
        -> (ini   : st)
        -> (seed  : container)
        -> m res

export
forM_ :  Iterable container element
      => MonadRec m
      => (run  : element -> m ())
      -> (seed : container)
      -> m ()
forM_ run = iterM (\e,_ => run e) (const ()) ()

export
foldM :  Iterable container element
      => MonadRec m
      => Monoid mo
      => (calc : element -> m mo)
      -> (seed : container)
      -> m mo
foldM calc = iterM (\e,acc => (<+> acc) <$> calc e) id neutral

--------------------------------------------------------------------------------
--          Iterable Implementations
--------------------------------------------------------------------------------

export
Iterable Nat Nat where
  iterM accum done ini seed =
    trSized seed ini $
      \case Z       => pure . Done . done
            v@(S k) => map (Cont k refl) . accum v

export
Iterable (List a) a where
  iterM accum done ini seed =
    trSized seed ini $
      \case Nil    => pure . Done . done
            h :: t => map (Cont t refl) . accum h

export
Iterable (List1 a) a where
  iterM accum done ini = iterM accum done ini . forget

export
Iterable Fuel () where
  iterM accum done ini seed =
    trSized seed ini $
      \case Dry    => pure . Done . done
            More f => map (Cont f refl) . accum ()

export
Iterable (SnocList a) a where
  iterM accum done ini seed =
    trSized seed ini $
      \case [<]     => pure . Done . done
            sx :< x => map (Cont sx refl) . accum x


infixl 0  ~~
prefix 1  |~
infix  1  ...

public export
(...) : (x : a) -> (y ~=~ x) -> (z : a ** y ~=~ z)
(...) x pf = (x ** pf)

public export
data FastDerivation : (x : a) -> (y : b) -> Type where
  (|~) : (x : a) -> FastDerivation x x
  (~~) : FastDerivation x y ->
         (step : (z : c ** y ~=~ z)) -> FastDerivation x z

public export
Calc : {x : a} -> {y : b} -> FastDerivation x y -> x = y
Calc (|~ x) = Refl
Calc {y} ((~~) {z=y} {y=y} der (MkDPair y Refl)) = Calc der

bad : Z = S Z
bad = Calc $ |~ Z ~~ Z ...(Refl)


||| Horizontal composition
module HoriComp

import Data.Vect
import VectHelp
import ProcessLib

import Proto

%default total
%access public export

resp: {m0,n0,m1,n1: Nat} ->
      {top0: Cut m0} -> {top1: Cut m1} -> {bot0: Cut n0} -> {bot1: Cut n1} ->
      ProcPID (MkNiche top0 bot0) ->
      ProcPID (MkNiche top1 bot1) ->
      (msg : Req (MkNiche (top0 ++ top1) (bot0 ++ bot1))) ->
      Process (ProcIF (MkNiche (top0 ++ top1) (bot0 ++ bot1)))
              (ProcIF (MkNiche (top0 ++ top1) (bot0 ++ bot1)) msg)
              Ready
              Ready
resp {top0 = top0} {top1 = top1} {bot0 = bot0} {bot1 = bot1} pid_a pid_b (Conn (TopOutWire loc) pid' target) =
  case elemConcat top0 top1 loc of
    Left l  => Request pid_a (Conn (TopOutWire l) pid' target)
    Right r => Request pid_b (Conn (TopOutWire r) pid' target)
resp {top0 = top0} {top1 = top1} {bot0 = bot0} {bot1 = bot1} pid_a pid_b (Conn (BotOutWire loc) pid' target) =
  case elemConcat bot0 bot1 loc of
    Left l  => Request pid_a (Conn (BotOutWire l) pid' target)
    Right r => Request pid_b (Conn (BotOutWire r) pid' target)
resp {top0 = top0} {top1 = top1} {bot0 = bot0} {bot1 = bot1} pid_a pid_b (Val (TopInWire loc) x) =
  case elemConcat top0 top1 loc of
    Left l  => Request pid_a (Val (TopInWire l) x)
    Right r => Request pid_b (Val (TopInWire r) x)
resp {top0 = top0} {top1 = top1} {bot0 = bot0} {bot1 = bot1} pid_a pid_b (Val (BotInWire loc) x) =
  case elemConcat bot0 bot1 loc of
    Left l  => Request pid_a (Val (BotInWire l) x)
    Right r => Request pid_b (Val (BotInWire r) x)

||| Monoidal operation on morphisms in the symetric monoidal category of processes
partial
(+): {m0,n0,m1,n1: Nat} ->
     {top0: Cut m0} -> {top1: Cut m1} -> {bot0: Cut n0} -> {bot1: Cut n1} ->
     Hom top0 bot0 -> Hom top1 bot1 -> Hom (top0 ++ top1) (bot0 ++ bot1)
(+) alpha beta = do Just pid_a <- Spawn alpha
                    Just pid_b <- Spawn beta
                    looper pid_a pid_b
  where
    looper: ProcPID (MkNiche top0 bot0) ->
            ProcPID (MkNiche top1 bot1) ->
            Process (ProcIF (MkNiche (top0 ++ top1) (bot0 ++ bot1))) () Ready Looping
    looper pid_a pid_b = do Respond (resp pid_a pid_b)
                            Loop (looper pid_a pid_b)


import Data.Vect

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

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

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

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


countFrom : Integer -> List Integer
countFrom n = n :: countFrom (n + 1)

partial
labelWith : List Integer -> List a -> List (Integer, a)
labelWith lbls [] = []
labelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals


module Data.DIMACS

import Data.List
import Data.Strings

import Text.Lexer
import Text.Parser

import Sat

%default total

public export
record CNFProblem where
  constructor MkCNFProblem
  numVars : Int
  numClauses : Int
  clauses : List Clause

export
Show CNFProblem where
  show prob = "CNF Problem (" ++ show prob.numVars ++ " vars, " ++ show prob.numClauses ++ " clauses):\n" ++
              show prob.clauses

data Token = Comment
           | Problem String
           | Zero
           | Lit String

Show Token where
  show Comment = "(comment)"
  show (Problem s) = "(problem: " ++ s ++ ")"
  show Zero = "0"
  show (Lit s) = s

comment : Lexer
comment = is 'c' <+> many (pred (/= '\n')) <+> is '\n' <+> many space

problem : Lexer
problem = is 'p' <+> is ' ' <+> many (pred (/= '\n')) <+> is '\n' <+> many space

zero : Lexer
zero = is '0' <+> many space

lit : Lexer
lit = opt (is '-') <+> some digit <+> some space

tokenMap : TokenMap Token
tokenMap = [
  (comment, \_ => Comment),
  (problem, Problem . trim),
  (zero, \_ => Zero),
  (lit, Lit . trim)
  ]

lexDimacs : String -> Either String (List Token)
lexDimacs s = let (toks, line, col, remainder) = lex tokenMap s in
                  if remainder == "" then Right $ map tok toks
                                     else Left $ "remaining: " ++ remainder

Parser : Type -> Type
Parser a = Grammar Token True a

isProblem : Token -> Maybe CNFProblem
isProblem (Problem s) = case words s of
                             ["p", "cnf", nVars, nClauses] =>
                               let numVars = cast nVars
                                   numClauses = cast nClauses in
                                     Just $ MkCNFProblem numVars numClauses []
                             _ => Nothing

isProblem _ = Nothing

literal : Token -> Maybe Sat.Lit
literal (Lit s) = let i = cast {to=Int} s in
                      if i > 0 then Just $ MkPos (MkVar (i-1))
                      else if i < 0 then Just $ MkNeg (MkVar ((-i) - 1))
                      else Nothing
literal _ = Nothing

isZero : Token -> Maybe ()
isZero Zero = Just ()
isZero _ = Nothing

isComment : Token -> Maybe ()
isComment Comment = Just ()
isComment _ = Nothing

parseClause : Parser (Maybe Clause)
parseClause = do
  lits <- many (terminal "literal" literal) <* terminal "zero" isZero
  many $ terminal "comment" isComment
  id $ case lits of
            [] => fatalError "empty clause can not be satisfied"
            (c::cs) => pure $ Just $ toClause (c::cs)

parseCNF : Parser CNFProblem
parseCNF = do
  many $ terminal "initial comment" isComment
  initState <- terminal "CNF problem header" isProblem
  parsedClauses <- some parseClause
  pure $ record { clauses = mapMaybe id parsedClauses } initState

showError : ParseError Token -> String
showError (Error e toks) = "parse error: " ++ e ++ "\nnext tokens: " ++ show toks

export
parseDIMACS : String -> Either String CNFProblem
parseDIMACS s = do
  toks <- lexDimacs s
  (parsed, toks) <- either (Left . showError) Right $ parse parseCNF toks
  Right parsed

export
showDIMACS : (Var, Bool) -> String
showDIMACS (MkVar d, True) = show (d+1)
showDIMACS (MkVar d, False) = show (-(d+1))


module ProofColDivSeqLvDown

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total
-- %language ElabReflection

mutual
  lvDown''' : (n, lv:Nat) -> Any (Not . Limited) (allDivSeq n (S lv))
    -> Either (Any (Not . Limited) (allDivSeq n lv))
        (Either (Any (Not . Limited) (allDivSeqA n lv))
          (Either (Any (Not . Limited) (allDivSeqB n lv))
            (Either (Any (Not . Limited) (allDivSeqC n lv))
              (Either (Any (Not . Limited) (allDivSeqD n lv))
                (Either (Any (Not . Limited) (allDivSeqE n lv))
                  (Either (Any (Not . Limited) (allDivSeqF n lv))
                          (Any (Not . Limited) (allDivSeqG n lv)) ))))))
  lvDown''' n lv = rewrite defini n lv in
    \prf => anyFinal (allDivSeq n lv)
                     (allDivSeqA n lv)
                     (allDivSeqB n lv)
                     (allDivSeqC n lv)
                     (allDivSeqD n lv)
                     (allDivSeqE n lv)
                     (allDivSeqF n lv)
                     (allDivSeqG n lv) prf

  lvDown'' : (n,lv:Nat)
    -> Either (Any (Not . Limited) (allDivSeq n lv))
        (Either (Any (Not . Limited) (allDivSeqA n lv))
          (Either (Any (Not . Limited) (allDivSeqB n lv))
            (Either (Any (Not . Limited) (allDivSeqC n lv))
              (Either (Any (Not . Limited) (allDivSeqD n lv))
                (Either (Any (Not . Limited) (allDivSeqE n lv))
                  (Either (Any (Not . Limited) (allDivSeqF n lv))
                          (Any (Not . Limited) (allDivSeqG n lv)) ))))))
      -> Any (Not . Limited) (allDivSeq n lv)
  lvDown'' n Z (Left l)                                                  = l
  lvDown'' n Z (Right (Left l))                                          = defini0 n $ Right (Left (changeA0 n l))
  lvDown'' n Z (Right (Right (Left l)))                                  = defini0 n $ (Right (Right (Left (changeB0 n l))))
  lvDown'' n Z (Right (Right (Right (Left l))))                          = defini0 n $ (Right (Right (Right (Left (changeC0 n l)))))
  lvDown'' n Z (Right (Right (Right (Right (Left l)))))                  = defini0 n $ (Right (Right (Right (Right (Left (changeD0 n l))))))
  lvDown'' n Z (Right (Right (Right (Right (Right (Left l))))))          = defini0 n $ (Right (Right (Right (Right (Right (Left (changeE0 n l)))))))
  lvDown'' n Z (Right (Right (Right (Right (Right (Right (Left l)))))))  = defini0 n $ (Right (Right (Right (Right (Right (Right (Left (changeF0 n l))))))))
  lvDown'' n Z (Right (Right (Right (Right (Right (Right (Right r))))))) = defini0 n $ (Right (Right (Right (Right (Right (Right (Right (changeG0 n r))))))))
  lvDown'' n (S lv) (Left l)                                                  = l
  lvDown'' n (S lv) (Right (Left l))                                          = defini3 n lv $ Right (Left (lvDown' (divNatNZ ((n+7)*3) 4 SIsNotZ) (S lv) (changeA n lv l)))
  lvDown'' n (S lv) (Right (Right (Left l)))                                  = defini3 n lv $ (Right (Right (Left (lvDown' (n*6+3) (S lv) (changeB n lv l)))))
  lvDown'' n (S lv) (Right (Right (Right (Left l))))                          = defini3 n lv $ (Right (Right (Right (Left (lvDown' (n*3+6) (S lv) (changeC n lv l))))))
  lvDown'' n (S lv) (Right (Right (Right (Right (Left l)))))                  = defini3 n lv $ (Right (Right (Right (Right (Left (lvDown' (divNatNZ ((n+1)*3) 2 SIsNotZ) (S lv) (changeD n lv l)))))))
  lvDown'' n (S lv) (Right (Right (Right (Right (Right (Left l))))))          = defini3 n lv $ (Right (Right (Right (Right (Right (Left (lvDown' (n*12+9) (S lv) (changeE n lv l))))))))
  lvDown'' n (S lv) (Right (Right (Right (Right (Right (Right (Left l)))))))  = defini3 n lv $ (Right (Right (Right (Right (Right (Right (Left (lvDown' (divNatNZ ((n+3)*3) 8 SIsNotZ) (S lv) (changeF n lv l)))))))))
  lvDown'' n (S lv) (Right (Right (Right (Right (Right (Right (Right r))))))) = defini3 n lv $ (Right (Right (Right (Right (Right (Right (Right (lvDown' (divNatNZ (n `minus` 21) 64 SIsNotZ) (S lv) (changeG n lv r)))))))))

  -- レベルを下げる事ができる
  lvDown' : (n, lv:Nat) -> Any (Not . Limited) $ allDivSeq n lv
                        -> Any (Not . Limited) $ allDivSeq n (pred lv)
  lvDown' n Z      prf = prf
  lvDown' n (S lv) prf = lvDown'' n lv $ lvDown''' n lv prf
-- ---------------------------------


module Control.Effect.State

import Control.EffectAlgebra
import Control.HigherOrder

import Control.Monad.State

import public Control.Effect.Reader
import public Control.Effect.Writer

||| State effect - the union of Reader and Writer effects.
public export
StateE : Type -> (Type -> Type) -> (Type -> Type)
StateE s = ReaderE s :+: WriterE s

public export
Inj (StateE s) sig => Inj (ReaderE s) sig where
  inj = inj {sub = StateE s, sup = sig} . Inl

public export
Inj (StateE s) sig => Inj (WriterE s) sig where
  inj = inj {sub = StateE s, sup = sig} . Inr

-- public export
-- get : Algebra sig m => Inj (StateE s) sig => m s
-- get = send {sig} {eff = StateE s} (Inl Ask)

-- public export
-- put : Algebra sig m => Inj (StateE s) sig => s -> m ()
-- put x = send {sig} {eff = StateE s} (Inr (Tell x))

namespace Algebra
  public export
  [State] Algebra sig m => Algebra (StateE s :+: sig) (StateT s m) where
    alg ctxx hdl (Inl (Inl Ask)) =
      ST $ \s => pure {f = m} (s, (s <$ ctxx))
    alg ctxx hdl (Inl (Inr (Tell s))) =
      ST $ \_ => pure {f = m} (s, ctxx)
    alg ctxx hdl (Inr x) = ST $ \r => do
     res <- alg
       {f = Functor.Compose}
       (r, ctxx) h x
     pure res
     where
      h : Handler ((s,) . ctx) n m
      h =
         (~<~)
          {ctx1 = (s,), ctx2 = ctx}
          {l = n}
          {m = StateT s m} {n = m} (uncurry runStateT) hdl

  %hint public export
  HintState : Algebra sig m => Algebra (StateE s :+: sig) (StateT s m)
  HintState = State


f : Nat -> Nat
f n = case n of case_val => ?f_rhs

g : Nat -> Nat
g n = (case n of case_val => ?g_rhs)

h : Nat -> Nat
h n = (case n of
            case_val => ?h_rhs     )

data Test = One
          | Two Nat
          | Three String Nat
          | Four

toTest : Nat -> Test

i : Nat -> Nat
i n = case toTest n of case_val => ?i_rhs

j : Nat -> Nat
j n = j_Where n where
  j_Where : Nat -> Nat
  j_Where k = (case toTest k of case_val => ?j_Where_rhs    )

k : Nat -> Nat
k n = (case toTest n of
            case_val => ?k_rhs)

l : Nat -> Nat -> Unit
l n m = case n of foo => case toTest m of case_val => ?l_rhs

m : Nat -> Nat -> Unit
m n k = (case n of foo => case toTest k of case_val => ?m_rhs  )

n : Nat -> Nat -> Unit
n k m = case k of foo => case toTest m of
                              case_val => ?n_rhs

o : Nat -> Nat -> Unit
o n m = (case n of foo => case toTest m of
                               case_val => ?o_rhs   )


||| For Plain Merge we need to compare Local types for equality.
module Sessions.Local.Same

import Decidable.Equality
import Data.List
import Data.List.Elem

import Data.List1

import Sessions.Meta
import Sessions.Local

%default total

notEC : Local.End = Choice ty whom selections -> Void
notEC Refl impossible

notVVElem : (x = y -> Void) -> Local.Call x = Local.Call y -> Void
notVVElem f Refl = f Refl

notVR : Local.Call x = Local.Rec y -> Void
notVR Refl impossible

notVC : Local.Call x = Choice ty whom selections -> Void
notVC Refl impossible

notRRBody : (x = y -> Void) -> Local.Rec x = Local.Rec y -> Void
notRRBody f Refl = f Refl

notRC : Local.Rec x = Choice ty whom selections -> Void
notRC Refl impossible

notCCTy : (tyA = tyB -> Void) -> Local.Choice tyA a as = Local.Choice tyB b bs -> Void
notCCTy f Refl = f Refl

notCCWhom : (a = b -> Void) -> Local.Choice tyA a as = Local.Choice tyA b bs -> Void
notCCWhom f Refl = f Refl

notCCSels : (as = bs -> Void) -> Local.Choice tyA a as = Local.Choice tyA a bs -> Void
notCCSels f Refl = f Refl

mutual

  export
  same : DecEq role label msg
      => (a,b : Local role label msg rs g)
             -> Dec (Equal a b)
  same End End = Yes Refl
  same End (Choice ty whom selections)
    = No (notEC)

  same (Call x) (Call y) with (decEq x y)
    same (Call x) (Call x) | (Yes Refl)
      = Yes Refl
    same (Call x) (Call y) | (No contra)
      = No (notVVElem contra)

  same (Call x) (Rec y)
    = No notVR
  same (Call x) (Choice ty whom selections)
    = No notVC

  same (Rec x) (Call y)
    = No (negEqSym notVR)
  same (Rec x) (Rec y) with (same x y)
    same (Rec x) (Rec x) | (Yes Refl) = Yes Refl
    same (Rec x) (Rec y) | (No contra)
      = No (notRRBody contra)

  same (Rec x) (Choice ty whom selections)
    = No notRC

  same (Choice ty whom selections) End
    = No (negEqSym notEC)
  same (Choice ty whom selections) (Call x)
    = No (negEqSym notVC)
  same (Choice ty whom selections) (Rec x)
    = No (negEqSym notRC)

  same (Choice tyA a as) (Choice tyB b bs) with (decEq tyA tyB)
    same (Choice tyA a as) (Choice tyA b bs) | (Yes Refl) with (decEq a b)
      same (Choice tyA a as) (Choice tyA a bs) | (Yes Refl) | (Yes Refl) with (List1.same as bs)
        same (Choice tyA a as) (Choice tyA a as) | (Yes Refl) | (Yes Refl) | (Yes Refl)
          = Yes Refl
        same (Choice tyA a as) (Choice tyA a bs) | (Yes Refl) | (Yes Refl) | (No contra)
          = No (notCCSels contra)

      same (Choice tyA a as) (Choice tyA b bs) | (Yes Refl) | (No contra)
        = No (notCCWhom contra)

    same (Choice tyA a as) (Choice tyB b bs) | (No contra)
      = No (notCCTy contra)

  namespace Pair

    notPairSameLabel : {am, bm : _}
                    -> {ab, bb : _}
                    -> (al = bl -> Void) -> (al, (am, ab)) = (bl, (bm, bb)) -> Void
    notPairSameLabel f Refl = f Refl

    notPairSameMsg : {al : _}
                  -> {ab, bb : _}
                  -> (am = bm -> Void) -> (al, (am, ab)) = (al, (bm, bb)) -> Void
    notPairSameMsg f Refl = f Refl

    notPairSameRest : {al : _}
                   -> {am : _}
                   -> (ab = bb -> Void) -> (al, (am, ab)) = (al, (am, bb)) -> Void
    notPairSameRest f Refl = f Refl

    export
    same : DecEq role label msg
        => (x,y : Branch role label msg rs g)
               -> Dec (Equal x y)
    same (al, (am, ab)) (bl, (bm, bb)) with (decEq al bl)
      same (al, (am, ab)) (al, (bm, bb)) | (Yes Refl) with (decEq am bm)
        same (al, (am, ab)) (al, (am, bb)) | (Yes Refl) | (Yes Refl) with (same ab bb)
          same (al, (am, ab)) (al, (am, ab)) | (Yes Refl) | (Yes Refl) | (Yes Refl)
            = Yes Refl
          same (al, (am, ab)) (al, (am, bb)) | (Yes Refl) | (Yes Refl) | (No contra)
            = No (notPairSameRest contra)
        same (al, (am, ab)) (al, (bm, bb)) | (Yes Refl) | (No contra)
          = No (notPairSameMsg contra)
      same (al, (am, ab)) (bl, (bm, bb)) | (No contra)
        = No (notPairSameLabel contra)

  namespace List

    notSamesRightEmpty : [] = x :: xs -> Void
    notSamesRightEmpty Refl impossible

    notSamesHead : {xs, ys : Branches' roel label msg rs g}
                -> (x = y -> Void)
                -> (::) x xs = (::) y ys
                -> Void
    notSamesHead f Refl = f Refl

    notSamesTail : {xs, ys : Branches' roel label msg rs g}
                -> (xs = ys -> Void)
                -> x :: xs = x :: ys
                -> Void
    notSamesTail f Refl = f Refl

    export
    same : DecEq role label msg
        => (as, bs : Branches' role label msg rs g)
                  -> Dec (Equal as bs)

    same [] [] = Yes Refl
    same [] (x :: xs) = No (notSamesRightEmpty)
    same (x :: xs) [] = No (negEqSym notSamesRightEmpty)
    same (x :: xs) (y :: ys) with (Pair.same x y)
      same (x :: xs) (x :: ys) | (Yes Refl) with (same xs ys)
        same (x :: ys) (x :: ys) | (Yes Refl) | (Yes Refl)
          = Yes Refl
        same (x :: xs) (x :: ys) | (Yes Refl) | (No contra)
          = No (notSamesTail contra)
      same (x :: xs) (y :: ys) | (No contra)
        = No (notSamesHead contra)

  namespace List1

    notSames1Head : (a = b -> Void) -> a ::: as = b ::: bs -> Void
    notSames1Head f Refl = f Refl

    notSames1Tail : (as = bs -> Void) -> a ::: as = a ::: bs -> Void
    notSames1Tail f Refl = f Refl

    export
    same : DecEq role label msg
        => (as, bs : Branches role label msg rs g)
                  -> Dec (Equal as bs)

    same (a ::: as) (b ::: bs) with (same a b)
      same (a ::: as) (a ::: bs) | (Yes Refl) with (same as bs)
        same (a ::: bs) (a ::: bs) | (Yes Refl) | (Yes Refl)
          = Yes Refl
        same (a ::: as) (a ::: bs) | (Yes Refl) | (No contra)
          = No (notSames1Tail contra)
      same (a ::: as) (b ::: bs) | (No contra)
        = No (notSames1Head contra)

-- [ EOF ]


%logging "declare.def.lhs" 10

data Tup : (a,b : Type) -> Type where
  MkTup : (1 f : a) -> (1 s : b) -> Tup a b

f : Tup a b -> a
f (MkTup f s) = f


incDim : Array (m * n::xs) t ->
         Array (m::n::xs) t

incDim v {m = Z}  = []
incDim v {m = S r} {n} =
    let (fstN, rest) =
      (take n v, drop n v) in
        fstN :: (incDim rest)