module Data.HashSet

import Data.Vector

%default total

public export
HashCode : Type
HashCode = Bits32

public export
interface (Eq a) => Hash a where
  hash : a -> HashCode

public export
Hash HashCode where
  hash = id

public export
Hash Int where
  hash = prim__zextInt_B32

public export
implementation (Hash a, Hash b) => Hash (a, b) where
  hash (x, y) = prim__xorB32 (997 * hash x) (991 * hash y)

Bitmap : Type
Bitmap = Bits32

Index : Type
Index = Nat

Cast Bits32 Nat where
  cast = cast . prim__zextB32_Int

mutual
  data Node a
    = Empty
    | Key HashCode a
    | HashCollision HashCode (Vector a)
    | SubTrie Bitmap (NodeList a)

  NodeList : Type -> Type
  NodeList a = Vector (Node a)

export
record HashSet a where
  constructor MkHashSet
  size : Nat
  root : NodeList a

Show a => Show (Node a) where
  show Empty = "E"
  show (Key h a) = "(K " ++ show a ++ ")"
  show (SubTrie bm l) = "(S " ++ show bm ++ " " ++ assert_total (show l) ++ ")"
  show _ = "*"

export
Show a => Show (HashSet a) where
  show (MkHashSet s r) = "HashSet " ++ show s ++ " " ++ show r

infixl 7 &
(&) : Bits32 -> Bits32 -> Bits32
(&) = prim__andB32

infixl 7 >>
(>>) : Bits32 -> Bits32 -> Bits32
(>>) = prim__lshrB32

infixl 7 <<
(<<) : Bits32 -> Bits32 -> Bits32
(<<) = prim__shlB32

(-) : Bits32 -> Bits32 -> Bits32
(-) x y = prim__zextInt_B32 (prim__zextB32_Int x - prim__zextB32_Int y)

shiftMask : Bits32 -> Bits32 -> Bits32 -> Bits32
shiftMask bits shift mask = (bits >> shift) & mask

popcnt : Bits32 -> Bits32
popcnt x =
  let x = x - shiftMask x 1 0x55555555
      x = (x & 0x33333333) + shiftMask x 2 0x33333333
      x = (x + (x >> 4)) & 0x0F0F0F0F
      x = x + (x >> 8)
      x = x + (x >> 16)
  in x & 0x0000003F

next5Bits : Bits32 -> HashCode -> HashCode
next5Bits level hashCode = shiftMask hashCode (5 * level) 0x1F

bitAt : Bits32 -> Bits32 -> Bool
bitAt pos bits = 1 == shiftMask bits pos 1

setBit : Bits32 -> Bits32 -> Bits32
setBit bitPos bits = prim__orB32 bits (1 << bitPos)

nodeIndex : Bits32 -> Bits32 -> Index
nodeIndex bitPos bitmap = cast (popcnt (bitmap & ((1 << bitPos) - 1)))

nodeAt : Index -> NodeList a -> Node a
nodeAt idx nodes = nodes !! idx

insertNode : Index -> NodeList a -> Node a -> NodeList a
insertNode idx nodes n = unsafeInsertAt idx n nodes

replaceNode : Index -> NodeList a -> Node a -> NodeList a
replaceNode idx nodes n = unsafeReplaceAt idx n nodes

{-
3.1 Search for a key Map Hash Array Mapped Trie (HAMT)

Compute a full 32 bit hash for the key, take the most significant t bits and use them as an integer to index into the root hash table. One of three cases may be encountered. First, the entry is empty indicating that the key is not in the hash tree. Second the entry is a Key/Value pair and the key either matches the desired key indicating success or not, indicating failure. Third, the entry has a 32 bit map sub-hash table and a sub-trie pointer, Base, that points to an ordered list of the non-empty sub-hash table entries.

Take the next 5 bits of the hash and use them as an integer to index into the bit Map. If this bit is a zero the hash table entry is empty indicating failure, otherwise, it’s a one, so count the one bits below it using CTPOP and use the result as the index into the non-empty entry list at Base. This process is repeated taking five more bits of the hash each time until a terminating key/value pair is found or the search fails. Typically, only a few iterations are required and it is important to note that the key is only compared once and that is with the terminating node key.
-}
export
member : (Hash a) => a -> HashSet a -> Bool
member key (MkHashSet _ root) =
  let rootPos = cast (next5Bits 0 hashCode)
  in memberOf root rootPos 1
  where
    hashCode : HashCode
    hashCode = hash key
    memberOf : NodeList a -> Index -> Bits32 -> Bool
    memberOf nodes index nextLevel =
      case nodeAt index nodes of
        Empty => False
        Key existingHashCode existingKey =>
          existingHashCode == hashCode && existingKey == key
        HashCollision existingHashCode keys =>
          existingHashCode == hashCode && elem key keys
        SubTrie bitmap nodes =>
          let
            bitPos = next5Bits nextLevel hashCode
            bitVal = bitAt bitPos bitmap
          in
            if bitVal
              then assert_total (memberOf nodes (nodeIndex bitPos bitmap) (nextLevel + 1))
              else False

{-
3.2 Insertion
The initial steps required to add a new key to the hash tree are identical to the search. The search algorithm is followed until one of two failure modes is encoun- tered.

Either an empty position is discovered in the hash table or a sub-hash table is found. In this case, if this is in the root hash table, the new key/value pair is simply substituted for the empty position. However, if in a sub-hash table then a new bit must be added to the bit map and the sub-hash table increased by one in size. A new sub-hash table must be allocated, the existing sub-table copied to it, the new key/value entry added in sub-hash sorted order and the old hash table made free.

Or the key will collide with an existing one. In which case the existing key must be replaced with a sub-hash table and the next 5 bit hash of the existing key computed. If there is still a collision then this process is repeated until no collision occurs. The existing key is then inserted in the new sub-hash table and the new key added. Each time 5 more bits of the hash are used the probability of a collision reduces by a factor of 1 . Occasionally an entire 32 bit hash may be consumed and 32 a new one must be computed to differentiate the two keys.
-}
insert' : (Hash a) => HashCode -> a -> HashSet a -> HashSet a
insert' hashCode key set@(MkHashSet size root) =
  case nodeAt rootPos root of
     Empty => insertRootNode (Key hashCode key)
     SubTrie bitmap nodes =>
       maybe set insertRootNode (insertIntoSubTrie bitmap nodes 1)
     node@(Key existingHashCode existingKey) =>
       if existingHashCode == hashCode
         then
           if existingKey == key
             then set
             else insertRootNode (collision existingKey)
         else
           maybe set insertRootNode (spawnSubTrie node existingHashCode 1)
     node@(HashCollision existingHashCode keys) =>
       if existingHashCode == hashCode
         then
           if elem key keys
             then set
             else insertRootNode (HashCollision hashCode (key :: keys))
         else
           maybe set insertRootNode (spawnSubTrie node existingHashCode 1)
  where
    rootPos : Index
    rootPos = cast (next5Bits 0 hashCode)
    insertRootNode : Node a -> HashSet a
    insertRootNode = MkHashSet (S size) . replaceNode rootPos root
    collision : a -> Node a
    collision existingKey = HashCollision hashCode (key :: singleton existingKey)
    mutual
      insertIntoSubTrie : Bitmap -> NodeList a -> Bits32 -> Maybe (Node a)
      insertIntoSubTrie bitmap nodes level =
        let
          bitPos = next5Bits level hashCode
          bitVal = bitAt bitPos bitmap
          nodePos = nodeIndex bitPos bitmap
        in
          if bitVal
            then SubTrie bitmap . replaceNode nodePos nodes <$> insertInto (nodeAt nodePos nodes) level
            else Just (SubTrie (setBit bitPos bitmap) (insertNode nodePos nodes (Key hashCode key)))

      insertInto : Node a -> Bits32 -> Maybe (Node a)
      insertInto (SubTrie bitmap nodes) level =
        assert_total (insertIntoSubTrie bitmap nodes (level + 1))
      insertInto node@(Key existingHashCode existingKey) level =
        if existingHashCode == hashCode
          then
            if existingKey == key
              then Nothing
              else Just (collision existingKey)
          else
            assert_total (spawnSubTrie node existingHashCode (level + 1))
      insertInto node@(HashCollision existingHashCode keys) level =
        if existingHashCode == hashCode
          then
            if elem key keys
              then Nothing
              else Just (HashCollision hashCode (key :: keys))
          else
            assert_total (spawnSubTrie node existingHashCode (level + 1))
      insertInto Empty _ = assert_unreachable

      spawnSubTrie : Node a -> HashCode -> Bits32 -> Maybe (Node a)
      spawnSubTrie node existingHashCode level =
        let bitPos = next5Bits level existingHashCode
            bitmap = setBit bitPos 0
        in insertIntoSubTrie bitmap (singleton node) level

export
insert : (Hash a) => a -> HashSet a -> HashSet a
insert key set = insert' (hash key) key set

export
empty : HashSet a
empty = MkHashSet 0 (replicate 32 Empty)

export
length : HashSet a -> Nat
length (MkHashSet size _) = size

fold : (acc -> elem -> acc) -> acc -> HashSet elem -> acc
fold f init (MkHashSet _ nodes) = foldNodes init nodes
  where
   mutual
    foldNodes : acc -> NodeList elem -> acc
    foldNodes acc nodes = foldl foldNode acc nodes
    foldNode : acc -> Node elem -> acc
    foldNode acc Empty = acc
    foldNode acc (Key _ k) = f acc k
    foldNode acc (HashCollision _ keys) = foldl f acc keys
    foldNode acc (SubTrie _ nodes) = assert_total (foldNodes acc nodes)

export
Foldable HashSet where
  foldl = fold
  foldr = fold . flip

export
filter : (Eq elem, Hash elem) => (elem -> Bool) -> HashSet elem -> HashSet elem
filter f (MkHashSet _ nodes) = foldNodes empty nodes
  where
   mutual
    foldNodes : HashSet elem -> NodeList elem -> HashSet elem
    foldNodes acc nodes = foldl foldNode acc nodes
    foldNode : HashSet elem -> Node elem -> HashSet elem
    foldNode acc Empty = acc
    foldNode acc (Key hashCode k) = insertWithHashCode hashCode acc k
    foldNode acc (HashCollision hashCode keys) = foldl (insertWithHashCode hashCode) acc keys
    foldNode acc (SubTrie _ nodes) = assert_total (foldNodes acc nodes)
    insertWithHashCode : HashCode -> HashSet elem -> elem -> HashSet elem
    insertWithHashCode hc acc e = if f e then insert' hc e acc else acc

export
into : (Hash a, Foldable f) => HashSet a -> f a -> HashSet a
into = foldl (flip insert)

export
fromList : (Hash a) => List a -> HashSet a
fromList = foldl (flip insert) empty

export
foldM : Monad m => (acc -> elem -> m acc) -> acc -> HashSet elem -> m acc
foldM f acc (MkHashSet _ nodes) = foldNodes f acc nodes
  where
   mutual
    foldNodes : (Monad m) => (a -> elem -> m a) -> a -> NodeList elem -> m a
    foldNodes f acc nodes = loop (length nodes) acc
      where
        loop Z     acc = pure acc
        loop (S k) acc = foldNode f acc (nodes !! k) >>= loop k
    foldNode : (Monad m) => (a -> elem -> m a) -> a -> Node elem -> m a
    foldNode f acc Empty = pure acc
    foldNode f acc (Key _ k) = f acc k
    foldNode f acc (HashCollision _ keys) = foldKeys f acc keys
    foldNode f acc (SubTrie _ nodes) = assert_total (foldNodes f acc nodes)
    foldKeys : (Monad m) => (a -> elem -> m a) -> a -> Vector elem -> m a
    foldKeys f acc keys = loop (length keys) acc
      where
        loop Z     acc = pure acc
        loop (S k) acc = f acc (keys !! k) >>= loop k


||| mutable array
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Data.Container.Mutable.Array

import Data.IOArray.Prims as Prim

import Decidable.Equality
import Data.Fin
import Data.So

%default total

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

||| IOArray0 is same to Data.IOArray.Prims.ArrayData. But it's type-safe
||| on index-access.
export
data IOArray0 : (capacity:Nat) -> Type -> Type where
  MkIOArray0 : Prim.ArrayData t -> IOArray0 (S ubound) t

export newIOArray0 : HasIO io => (capacity:Nat)
    -> {auto 0 capacity_isnt_zero: So (capacity /= 0)}
    -> t
    -> io (IOArray0 capacity t)
newIOArray0 c@(S _) x =
  pure $ MkIOArray0 !(primIO $ Prim.prim__newArray (cast c) x)

namespace Zero

  export %inline readIOArray : HasIO io => Fin c -> IOArray0 c t -> io t
  readIOArray i (MkIOArray0 xs)
    = primIO $ Prim.prim__arrayGet xs (cast $ finToNat i)

  export %inline writeIOArray : HasIO io => Fin c -> t -> IOArray0 c t -> io ()
  writeIOArray i x (MkIOArray0 xs)
    = primIO $ Prim.prim__arraySet xs (cast $ finToNat i) x

  namespace List

    export writeIOArray : HasIO io
        => {c:Nat} -> (from:Fin c) -> List t -> IOArray0 c t -> io ()
    writeIOArray _ [] _ = pure ()
    writeIOArray {c=c} i (x::xs) ys = do
      writeIOArray i x ys
      case natToFin (S $ finToNat i) c of
           Nothing => pure ()
           Just i' => writeIOArray i' xs ys

  export fromList : HasIO io
      => (xs:List t)
      -> io (Maybe (IOArray0 (length xs) t))
  fromList [] = pure Nothing
  fromList (x::xs) = do
    arr <- newIOArray0 (S $ length xs) x
    writeIOArray 0 xs arr
    pure $ Just arr

  export toList : HasIO io => {n:_} -> IOArray0 (S n) t -> io (List t)
  toList {n=n} xs = go last []
    where
      go : Fin (S n) -> List t -> io (List t)
      go i ys = do
        y <- readIOArray i xs
        case i of
             FZ    => pure  (y::ys)
             FS i' => assert_total $ go (weaken i') (y::ys)

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

||| IOArray has runtime boundary check
export
record IOArray t where
  constructor MkIOArray
  ub : Nat
  content : IOArray0 (S ub) t

export %inline ubound : IOArray t -> Nat
ubound xs = xs.ub

export %inline capacity : IOArray t -> Nat
capacity xs = S $ ubound xs

export capacity_is_ubound_plus1 : forall xs. (S (ubound xs)) = capacity xs
capacity_is_ubound_plus1 = Refl

export newIOArray : HasIO io
    => (capacity:Nat) -> {auto capacity_isnt_zero: So (capacity /= 0)}
    -> t
    -> io (IOArray t)
newIOArray capacity@(S u) x = pure $ MkIOArray u !(newIOArray0 capacity x)

namespace Fin
  export %inline readIOArray : HasIO io => (xs:IOArray t) -> Fin (S $ ubound xs) -> io t
  readIOArray xs i = pure $ !(readIOArray i xs.content)

  export %inline writeIOArray : HasIO io => (xs:IOArray t) -> Fin (S $ ubound xs) -> t -> io ()
  writeIOArray xs i x = writeIOArray i x xs.content

  export %inline restrict : (xs:IOArray t) -> Integer -> Fin (S $ ubound xs)
  restrict xs i = restrict (ubound xs) i

namespace Nat
  export readIOArray : HasIO io => Nat -> IOArray t -> io (Maybe t)
  readIOArray i xs with (integerToFin (cast i) (capacity xs))
    readIOArray i xs | Just i' = pure $ Just $ !(readIOArray i' xs.content)
    readIOArray i xs | Nothing = pure Nothing

  export writeIOArray : HasIO io => Nat -> t -> IOArray t -> io Bool
  writeIOArray i x xs with (integerToFin (cast i) (capacity xs))
    writeIOArray i x xs | Just i' = writeIOArray i' x xs.content >> pure True
    writeIOArray i x xs | Nothing = pure False

namespace List
  export fromList : HasIO io => List t -> io (Maybe (IOArray t))
  fromList [] = pure Nothing
  fromList (x::xs) = do
    arr <- newIOArray (S $ length xs) x
    writeIOArray arr 0 x
    pure $ Just arr

  export toList : HasIO io => IOArray t -> io (List t)
  toList xs = go last []
    where
      go : Fin (S $ ubound xs) -> List t -> io (List t)
      go i ys = do
        y <- readIOArray xs i
        case i of
             FZ    => pure  (y::ys)
             FS i' => assert_total $ go (weaken i') (y::ys)

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


{-
System.Int32[]
17
25
42
-}
import CIL.FFI.Array
import Data.Vect

infixl 5 >=>

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

main : CIL_IO ()
main = do
  array <- arrayOf CILTyInt32 [17, 25]
  putStrLn !(ToString array)
  let a = \i => get array i
  for_ [0..1] $
    a >=> printLn
  printLn (!(a 0) + !(a 1))

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


module Circuits.Idealised.Types

import Decidable.Equality

import Data.List.Elem

import public Circuits.Common

%default total

public export
data GateKind = AND  | IOR  | XOR
              | ANDN | IORN | XORN | JOIN

export
Show GateKind where
  show AND  = "and"
  show IOR  = "or"
  show XOR  = "xor"
  show ANDN = "nand"
  show IORN = "nor"
  show XORN = "xnor"
  show JOIN = "join"

public export
data Direction = INPUT | OUTPUT

Uninhabited (INPUT = OUTPUT) where
  uninhabited Refl impossible

DecEq Direction where
  decEq INPUT INPUT   = Yes Refl
  decEq INPUT OUTPUT  = No absurd
  decEq OUTPUT INPUT  = No (negEqSym absurd)
  decEq OUTPUT OUTPUT = Yes Refl

export
Show Direction where
  show INPUT  = "input"
  show OUTPUT = "output"

public export
data PortHasProperties : Direction -> DType -> (Direction, DType) -> Type
  where
    PortHas : PortHasProperties flow type (flow,type)

public export
data Ty : Type where
  TyUnit : Ty
  TyPort : (Direction, DType) -> Ty

  TyGate : Ty

export
Show Ty where
  show TyUnit = "()"
  show (TyPort (d,t)) = concat ["TyPort(", show d, ",", show t, ")"]
  show TyGate = "TyGate"

Uninhabited (TyUnit = (TyPort x)) where
  uninhabited Refl impossible

Uninhabited (TyUnit = TyGate) where
  uninhabited Refl impossible

Uninhabited (TyPort x = TyGate) where
  uninhabited Refl impossible

export
DecEq Ty where
  decEq TyUnit TyUnit = Yes Refl
  decEq TyUnit (TyPort x) = No absurd
  decEq TyUnit TyGate = No absurd

  decEq (TyPort x) TyUnit = No (negEqSym absurd)
  decEq (TyPort x) (TyPort y) with (decEq x y)
    decEq (TyPort x) (TyPort x) | (Yes Refl)
      = Yes Refl
    decEq (TyPort x) (TyPort y) | (No contra)
      = No (\Refl => contra Refl)
  decEq (TyPort x) TyGate = No (absurd)

  decEq TyGate TyUnit = No (negEqSym absurd)
  decEq TyGate (TyPort x) = No (negEqSym absurd)
  decEq TyGate TyGate = Yes Refl

public export
data Used : (Ty, Usage) -> Type where
  IsUsed : Used (type, USED)

Uninhabited (Used (type,FREE)) where
  uninhabited IsUsed impossible

export
used : (p : (Ty,Usage)) -> Dec (Used p)
used (ty,USED) = Yes IsUsed
used (ty,FREE) = No absurd

public export
data Use : (old : List (Ty, Usage))
        -> (prf : Elem (type,FREE) old)
        -> (new : List (Ty, Usage))
        -> Type
  where
    H : Use ((type,FREE) :: rest)
            Here
            ((type,USED) :: rest)
    T : Use old later new
     -> Use ((type',usage')::old) (There later) ((type',usage')::new)

export
use : (ctxt : List (Ty, Usage))
   -> (prf : Elem (type, FREE) ctxt)
          -> (DPair (List (Ty, Usage))
                    (Use ctxt prf))
use ((type, FREE) :: xs) Here
  = (MkDPair ((type, USED) :: xs) H)
use ((y, z) :: xs) (There x) with (use xs x)
  use ((y, z) :: xs) (There x) | ((MkDPair fst snd))
    = (MkDPair ((y, z) :: fst) (T snd))

export
useAlt : {ctxt : List (Ty, Usage)}
      -> (prf : Elem (type, FREE) ctxt)
             -> (DPair (List (Ty, Usage))
                       (Use ctxt prf))
useAlt {ctxt = ((type, FREE) :: xs)} Here
  = MkDPair ((type, USED) :: xs) H
useAlt {ctxt = (y :: xs)} (There x) with (useAlt x)
  useAlt {ctxt = ((y, z) :: xs)} (There x) | (MkDPair fst snd) = MkDPair ((y, z) :: fst) (T snd)

-- [ EOF ]


module Parser

import Data.String
import Data.List

public export
Input : Type
Input = List Char

public export
data ParseResult a = Done (a, Input) | Error String

-- To make a parser we need to take a function to maps from input to
-- A parse result and feed it into the AParser constuctor
public export
data Parser : Type -> Type where
  AParser : (Input -> ParseResult a) -> Parser a

%name Parser parser, parser2

-- To actually apply a parser we need to call the parse function
export
parse : Parser a -> Input -> ParseResult a
parse (AParser p) input = p input

export
doParse : Parser a -> String -> ParseResult a
doParse parser str = parse parser (unpack str)

export
eitherParse : Parser a -> String -> Either String a
eitherParse parser input =
  case doParse parser input of
    Done (a, rest) => Right a
    Error str => Left str

-- This is a more general form of map, it takes a parser, applies it
-- and the maps over both the result and the remaining input
export
continue : Parser a -> ((a, Input) -> ParseResult b) -> Parser b
continue parser f = AParser $ \input =>
    case parse parser input of
      Error str => Error str
      Done a => f a

public export
Functor ParseResult where
  map _ (Error str) = Error str
  map f (Done (a, input)) = Done (f a, input)

public export
Functor Parser where
  -- map : (a -> b) -> Parser a -> Parser b
  map f parser = AParser $ map f . parse parser

public export
Applicative Parser where
  (<*>) parser1 parser2 =
    AParser $ \input =>
      case parse parser1 input of
        Error err => Error err
        Done (a, rest) => parse (map a parser2) rest

  pure a = AParser \input => Done (a, input)

public export
Monad Parser where
  -- (>>=) : Parser a -> (a -> Parser b) -> Parser b
  (>>=) parser f = continue parser (\(a, rest) => parse (f a) rest)

-- Defining Basic parsers

export
end : ParseResult a
end = Error "End of Input"

export
failure : Parser a
failure = AParser $ \input => Error "Always fails"

export
parseError : String -> Parser a
parseError err = AParser $ \input => Error err

export
pToken : Parser Char
pToken = AParser $ \input =>
  case input of
    [] => end
    (c :: cs) => Done (c, cs)

export
validate : (a -> Bool) -> Parser a -> Parser a
validate f parser = do
  result <- parser
  if f result
    then pure result
    else parseError "Invalid Parse"

export
pBool : (Char -> Bool) -> Parser Char
pBool f = validate f pToken

-- parse a specific word
export
pTag : String -> Parser String
pTag tag = AParser $ go (unpack tag) []
  where
    go : List Char -> List Char -> Input -> ParseResult String
    go [] acc input = Done (pack . reverse $ acc, input)
    go (c :: cs) acc [] = end
    go (c :: cs) acc (n :: rest) =
      if c == n then go cs (n :: acc) rest
      else Error "Did not match tag"

-- Apply a parser N times
-- This should return a Vect
-- There must be a better way to do this
export
pN : Parser a -> Nat -> Parser (List a)
pN parser n = go parser n []
  where
    go : Parser a -> Nat -> List a -> Parser (List a)
    go parser 0 xs = failure
    go parser (S k) acc = do
      parsed <- parser
      let newAcc = parsed :: acc
      case k of
        0 => pure $ reverse newAcc
        k => go parser k newAcc

export
pChar : Char -> Parser Char
pChar c = pBool (==c)

export
pDigit : Parser Char
pDigit = pBool isDigit

export
many : Parser a -> Parser (List a)
many parser = AParser $ map reverse . go []
  where
    go : List a -> Input -> ParseResult (List a)
    go acc input =
      case parse parser input of
        Done (parsed, rest) => go (parsed :: acc) rest
        Error str => Done (acc, input)

export
manyString : Parser Char -> Parser String
manyString parser = map pack (many parser)

export
or : Parser a -> Parser a -> Parser a
or parser1 parser2 = AParser $ \input =>
  case parse parser1 input of
    Done (result, rest) => Done (result, rest)
    Error _ => parse parser2 input

infixr 4 <^>
export
(<^>) : Parser a -> Parser a -> Parser a
(<^>) x y = or x y

export
while : (Char -> Bool) -> Parser String
while f = manyString (pBool f)

export
until : (Char -> Bool) -> Parser String
until f = while (not . f)

export
pWhiteSpace : Parser String
pWhiteSpace = while isSpace

export
-- Parse until it encounters whitespace
-- Doesn't consume the whitespace
pWord : Parser String
pWord = until isSpace

export
mapM : (a -> Maybe b) -> Parser a -> Parser b
mapM f parser = do
  parsed <- parser
  case f parsed of
    Nothing => parseError "Invalid mapM"
    Just a => pure a

export
pInteger : Parser Integer
pInteger = mapM parseInteger (while validChar)
  where validChar : Char -> Bool
        validChar '+' = True
        validChar '-' = True
        validChar c = isDigit c

export
pNat : Parser Nat
pNat = map stringToNatOrZ (while isDigit)

export
andThen : Parser a -> Parser b -> Parser (a,b)
andThen parser1 parser2 = do
  parsed1 <- parser1
  parsed2 <- parser2
  pure (parsed1, parsed2)

infixl 3 <&>
export
(<&>) : Parser a -> Parser b -> Parser (a,b)
(<&>) x y = andThen x y

export
thenDrop : Parser a -> Parser b -> Parser a
thenDrop parser1 parser2 = map fst (andThen parser1 parser2)

infixl 3 :>
export
(:>) : Parser a -> Parser b -> Parser a
(:>) x y = thenDrop x y

export
sepBy : Parser a -> Parser b -> Parser (List a)
sepBy parser1 parser2 = do
  most <- many (thenDrop parser1 parser2)
  AParser $ (\input =>
      case parse parser1 input of
        Done (result, rest) => Done (most ++ [result], rest)
        Error str => Done (most, input))

export
-- Matches the end of the file
theEnd : Parser ()
theEnd = AParser $ \input =>
  if input == [] then Done ((), [])
  else Error "Expected End of File"

export
-- Parses a word and consume whitespace
pWord' : Parser String
pWord' = pWord :> pWhiteSpace

export
ignore : Parser a -> Parser ()
ignore parser = map (\i => ()) parser

export
oneOf : List (Parser a) -> Parser a
oneOf parsers = foldl (<^>) (parseError "No opertion found") parsers

export
ignoreThen : Parser a -> Parser b -> Parser b
ignoreThen parser1 parser2 = map snd (parser1 <&> parser2)

-- Parses a line as text and consumes the newline
-- TODO make this work on windows style newlines
export
line : Parser String
line = (until (=='\n')) `thenDrop` (pChar '\n')

export
pLines : Parser a -> Parser (List a)
pLines parser = sepBy parser line

infixl 3 <:
export
(<:) : Parser a -> Parser b -> Parser b
(<:) x y = ignoreThen x y


add : Int -> Int -> Int
add = (+)

-- lift to nearest binder
addm1 : Maybe Int -> Maybe Int -> Maybe Int
addm1 x y = let z = x in pure (add !z !y)

-- lift to nearest binder
addm2 : Maybe Int -> Maybe Int -> Maybe Int
addm2 = \x, y => pure (!x + !y)

getLen : String -> IO Nat
getLen str = pure (length str)

fakeGetLine : String -> IO String
fakeGetLine str = pure str

-- lift out innermost first
printThing1 : IO ()
printThing1 = printLn !(getLen !(fakeGetLine "line1"))

-- lift out leftmost first
printThing2 : IO ()
printThing2 = printLn (!(fakeGetLine "1") ++ !(fakeGetLine "2"))

-- don't lift out of if
printBool : Bool -> IO ()
printBool x
    = if x
         then putStrLn !(fakeGetLine "True")
         else putStrLn !(fakeGetLine "False")

main : IO ()
main = do
  printLn $ addm1 (Just 3) (Just 4)
  printLn $ addm2 (Just 3) (Just 4)
  printThing1
  printThing2
  printBool True
  printBool False


import OCaml.IO

orderedType : Type -> Type
orderedType t = Module [ val "compare" (t -> t -> Int) ]

setSig : Type -> Type -> Type
setSig elt t = Module [ val "empty" t
                      , val "is_empty" (t -> Bool)
                      , val "mem" (elt -> t -> Bool)
                      , val "add" (elt -> t -> t)
                      ]

makeset : {auto p : OCaml_Types elt} ->
          orderedType elt ->
          (t : Type ** p : OCaml_Types t ** setSig elt t)
makeset {elt} ordered =
  MkDPair Ptr
  (MkDPair OCaml_Ptr
    (unsafePerformIO $
     ocamlCall "Stdlib.Set.Make" (orderedType elt -> OCaml_IO (setSig elt Ptr)) ordered))

IntOrdered : orderedType Int
IntOrdered = struct [ Let "compare" (\x => \y => x - y) ]

main : IO ()
main = do
  let MkDPair s (MkDPair _ ops) = makeset IntOrdered
  let set = ops#"empty"
  let set1 = (ops#"add") 45 set
  if (ops#"is_empty") set then putStrLn "'set' is empty"
                          else putStrLn "'set' is not empty"
  if (ops#"is_empty") set1 then putStrLn "'set1' is empty"
                           else putStrLn "'set1' is not empty"


module Main

import Fs
import Control.Monad.Free
import Data.Vect

anyVect : (n ** Vect n String)
anyVect = (3 ** ["Rod", "Jane", "Freddy"])

data FileSystemF next
  = WriteFile FilePath String next
  | ReadFile FilePath (String -> next)

FileSystem : Type -> Type
FileSystem = Free FileSystemF

Functor FileSystemF where
  map f (WriteFile filePath contents next) = WriteFile filePath contents (f next)
  map f (ReadFile filePath fNext) = ReadFile filePath (f . fNext)

writeFile : FilePath -> Contents -> FileSystem Unit
writeFile filePath contents = liftFree $ WriteFile filePath contents ()

readFile : FilePath -> FileSystem String
readFile filePath = liftFree $ ReadFile filePath id

echoHello : FileSystem Unit
echoHello = do
  writeFile "foo.txt" "hello, world!"
  contents <- readFile "foo.txt"
  writeFile "foo.txt" (contents <+> "!")

interpreter : FileSystemF a -> JS_IO a
interpreter (WriteFile filePath contents next) = writeFileSync filePath contents *> pure next
interpreter (ReadFile filePath fNext) = do
  contents <- readFileSync filePath
  pure (fNext contents)

main : JS_IO ()
main = foldFree interpreter echoHello


module Flexidisc.OrdList.HereOrNot

import Flexidisc.Dec.IsYes
import Flexidisc.OrdList.Fresh
import Flexidisc.OrdList.Label
import Flexidisc.OrdList.Nub
import Flexidisc.OrdList.Row
import Flexidisc.OrdList.Sub
import Flexidisc.OrdList.Type

%default total

||| A proof that labels that are in both lists have the same values
public export
data HereOrNot : (xs, ys : OrdList k v o) -> Type where
  ||| It holds for two empty `OrdList`
  Empty : HereOrNot [] []
  ||| If an element of the first list is not in the second list, it holds
  Skip  : DecEq k => {xs : OrdList k v o} -> HereOrNot xs ys -> IsFresh l ys -> HereOrNot ((l, ty) :: xs) ys
  ||| If an element of the second list is not in the first list, it holds
  Extra : DecEq k => {xs : OrdList k v o} -> HereOrNot xs ys -> IsFresh l xs -> HereOrNot xs ((l, ty) :: ys)
  ||| If an element is in both list, the values should be the same
  Keep  : HereOrNot xs ys -> HereOrNot ((l, ty) :: xs) ((l, ty) :: ys)

export
toRow : HereOrNot [(k, v)] ys -> Maybe (OrdRow k v ys)
toRow (Skip compat fresh)  = Nothing
toRow (Extra compat fresh) = There <$> toRow compat
toRow (Keep compat)        = Just Here

%name HereOrNot compat, can, prf

export
toSub : HereOrNot xs ys -> Maybe (Sub xs ys)
toSub Empty                = Just Empty
toSub (Skip compat fresh)  = Nothing
toSub (Extra compat fresh) = map Skip $ toSub compat
toSub (Keep compat)        = map Keep $ toSub compat


total
notHack : Nat -> (Nat, Nat)
notHack Z = (Z, Z)
notHack (S n) = let (baz1, baz2) = notHack n
                in (baz2, S baz1)

total
hack : Nat -> (Void, Void)
hack n = let (baz1, baz2) = hack n
         in (baz1, baz2)


module LightClick.Connection

import Data.Vect

import Toolkit.Decidable.Informative
import Toolkit.Data.Rig

import LightClick.Types
import LightClick.Types.Equality
import LightClick.Types.Compatibility

%default total

namespace Port

  public export
  data Compatible : (left  : Ty (PORT l))
                 -> (right : Ty (PORT r))
                          -> Type
    where
      IsSafe : (flow  : Safe                   dl dr)
            -> (sens  : Sensitivity.Compatible sl sr)
            -> (wtype : WireType.Compatible    wl wr)
            -> (dtype : Data.Compatible        tl tr)
            -> Port.Compatible (TyPort l dl sl wl tl ul)
                               (TyPort r dr sr wr tr ur)

  directionUnsafe : (Safe dir x -> Void)
                 -> Compatible (TyPort l dir sense wty type usage) (TyPort r x y z t w)
                 -> Void
  directionUnsafe contra (IsSafe flow sens wtype dtype) = contra flow

  sensitivityInCompatible : (Compatible sense y -> Void)
                         -> Compatible (TyPort l dir sense wty type usage) (TyPort r x y z t w)
                         -> Void
  sensitivityInCompatible contra (IsSafe flow sens wtype dtype) = contra sens

  wireTypesInCompatible : (Compatible wty z -> Void)
                       -> Compatible (TyPort l dir sense wty type usage) (TyPort r x y z t w)
                       -> Void
  wireTypesInCompatible contra (IsSafe flow sens wtype dtype) = contra wtype

  dataTypeInCompatible : (Compatible type t -> Void)
                    -> Compatible (TyPort l dir sense wty type usage) (TyPort r x y z t w) -> Void
  dataTypeInCompatible contra (IsSafe flow sens wtype dtype) = contra dtype

  public export
  data Error = InCompatSensitivity Sensitivity.Error
             | InCompatDirection   Direction.Safe.Error
             | InCompatWTypes      Wire.Error
             | InCompatDTypes      Data.Error

  export
  compatible : (left  : Ty (PORT l))
            -> (right : Ty (PORT r))
                     -> DecInfo Port.Error
                               (Compatible left right)
  compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) with (safe dx dy)
    compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) with (compatible sx sy)
      compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) | (Yes prfS) with (compatible wx wy)
        compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) | (Yes prfS) | (Yes prfW) with (compatible tx ty)
          compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) | (Yes prfS) | (Yes prfW) | (Yes prfT)
            = Yes (IsSafe prfD prfS prfW prfT)

          compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) | (Yes prfS) | (Yes prfW) | (No msg contra)
            = No (InCompatDTypes msg) (dataTypeInCompatible contra)
        compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) | (Yes prfS) | (No msg contra)
          = No (InCompatWTypes msg) (wireTypesInCompatible contra)
      compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) | (No msg contra)
        = No (InCompatSensitivity msg) (sensitivityInCompatible contra)
    compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (No msg contra)
      = No (InCompatDirection msg) (directionUnsafe contra)

namespace Fanout

  namespace PortList

    public export
    data Compatible : (input : Ty (PORT s))
                   -> (fan   : DVect String (Ty . PORT) n names)
                            -> Type
      where
        Empty : PortList.Compatible i Nil
        Cons : {x : Ty (PORT s)}
            -> {rest : DVect String (Ty . PORT) n names}
            -> Port.Compatible i x
            -> PortList.Compatible i rest
            -> PortList.Compatible i (x::rest)

    headNotCompat : {xs : DVect String (Ty . PORT) n names}
                 -> (Port.Compatible i x -> Void)
                 -> PortList.Compatible i (x `DVect.(::)` xs)
                 -> Void
    headNotCompat contra (Cons prf rest) = contra prf

    restNotCompat : {xs : DVect String (Ty . PORT) n names}
                 -> (Compatible i xs -> Void)
                 -> Compatible i (x `DVect.(::)` xs)
                 -> Void
    restNotCompat contra (Cons prf rest) = contra rest

    public export
    data Error = PListError Nat (Ty (PORT s)) Port.Error

    export
    compatible : (input : Ty (PORT s))
              -> (ports : DVect String (Ty . PORT) n names)
                      -> DecInfo PortList.Error
                                 (PortList.Compatible input ports)
    compatible i Nil = Yes Empty
    compatible i (x :: xs) with (compatible i x)
      compatible i (x :: xs) | (Yes prfX) with (compatible i xs)
        compatible i (x :: xs) | (Yes prfX) | Yes prfXs = Yes (Cons prfX prfXs)

        compatible i (x :: xs) | (Yes prfX) | (No (PListError pos y err) contra)
          = No (PListError (S pos) y err) (restNotCompat contra)
      compatible i (x :: xs) | (No msg contra) = No (PListError Z x msg) (headNotCompat contra)

  public export
  data Compatible : (input : Ty (PORT s))
                 -> (fan   : DVect String (Ty . PORT) (S (S n)) names)
                 -> Type
    where
      CompatFanout : PortList.Compatible input fan
                  -> Compatible input fan

  notCompatFanout : (PortList.Compatible input (x :: (y :: fan)) -> Void)
                 -> Fanout.Compatible input (x :: (y :: fan)) -> Void
  notCompatFanout contra (CompatFanout prf) = contra prf

  export
  compatible : (input : Ty (PORT s))
            -> (fan   : DVect String (Ty . PORT) (S (S n)) names)
                     -> DecInfo PortList.Error
                                (Fanout.Compatible input fan)

  compatible input (x::y::fan) with (PortList.compatible input (x::y::fan))
    compatible input (x::y::fan) | Yes prf = Yes (CompatFanout prf)
    compatible input (x::y::fan) | No msg contra = No msg (notCompatFanout contra)

namespace Mux

  public export
  data Error = CtrlNotSafe (Ty (PORT s)) Port.Error
             | MuxNotSafe (PortList.Error)

  namespace PortList

    public export
    data Compatible : (ports : DVect String (Ty . PORT) n names)
                   -> (o     : Ty (PORT s))
                            -> Type
      where
        Empty : Compatible Nil o
        Cons : {x : Ty (PORT s)}
            -> {rest : DVect String (Ty . PORT) n names}
            -> Port.Compatible x o
            -> PortList.Compatible     rest o
            -> PortList.Compatible (x::rest) o

    headNotCompat : {xs : DVect String (Ty . PORT) n names}
                 -> (Port.Compatible x o -> Void)
                 -> PortList.Compatible (x `DVect.(::)` xs) o
                 -> Void
    headNotCompat contra (Cons prf rest) = contra prf

    restNotCompat : {xs : DVect String (Ty . PORT) n names}
                 -> (Compatible xs o -> Void)
                 -> Compatible (x `DVect.(::)` xs) o
                 -> Void
    restNotCompat contra (Cons prf rest) = contra rest

    export
    compatible : (ports : DVect String (Ty . PORT) n names)
              -> (o     : Ty (PORT s))
                        -> DecInfo PortList.Error
                                   (PortList.Compatible ports o)
    compatible Nil o = Yes Empty
    compatible (x :: xs) o with (compatible x o)
      compatible (x :: xs) o | (Yes prfX) with (compatible xs o)
        compatible (x :: xs) o | (Yes prfX) | Yes prfXs = Yes (Cons prfX prfXs)

        compatible (x :: xs) o | (Yes prfX) | (No (PListError pos y err) contra)
          = No (PListError (S pos) y err) (restNotCompat contra)
      compatible (x :: xs) o | (No msg contra) = No (PListError Z x  msg) (headNotCompat contra)

  namespace Fanin

    public export
    data Compatible : (fan   : DVect String (Ty . PORT) (S (S n)) names)
                   -> (output : Ty (PORT s))
                   -> Type
      where
        CompatFanin : PortList.Compatible fan output
                   -> Compatible fan output

    notCompatFanin : (PortList.Compatible (x :: (y :: fan)) output -> Void)
                   -> Fanin.Compatible (x :: (y :: fan)) output -> Void
    notCompatFanin contra (CompatFanin prf) = contra prf

    export
    compatible : (fan    : DVect String (Ty . PORT) (S (S n)) names)
              -> (output : Ty (PORT s))
                       -> DecInfo PortList.Error
                                  (Fanin.Compatible fan output)

    compatible (x::y::fan) output with (PortList.compatible (x::y::fan) output)
      compatible (x::y::fan) output | Yes prf = Yes (CompatFanin prf)
      compatible (x::y::fan) output | No msg contra = No msg (notCompatFanin contra)

  public export
  data Compatible : (fan    : DVect String (Ty . PORT) (S (S n)) names)
                 -> (ctrl   : Ty (PORT c))
                 -> (output : Ty (PORT o))
                           -> Type
    where
      CompatMux : (fan  : DVect String (Ty . PORT) (S (S n)) names)
               -> (ctrl : Ty (PORT c))
               -> (out  : Ty (PORT o))
               -> (safeCTRL  : Port.Compatible ctrl (Control.mkDual ctrl))
               -> (safeFanIn : Fanin.Compatible fan out)
                            -> Compatible fan ctrl out

  faninNotCompat : (Fanin.Compatible fan output -> Void)
                -> Compatible fan ctrl output -> Void
  faninNotCompat contra (CompatMux f c o prfCtrl prfFanin) = contra prfFanin

  ctrlNotCompat : {fan : DVect String (Ty . PORT) (S (S n)) names}
               -> (Port.Compatible ctrl (Control.mkDual ctrl) -> Void)
               -> Compatible fan ctrl output
               -> Void
  ctrlNotCompat contra (CompatMux f c o prfCtrl prfFanin) = contra prfCtrl

  export
  compatible : (fanin  : DVect String (Ty . PORT) (S (S n)) names)
            -> (ctrl   : Ty (PORT c))
            -> (output : Ty (PORT o))
            -> DecInfo Mux.Error
                       (Compatible fanin ctrl output)
  compatible fan ctrl output with (Fanin.compatible fan output)
    compatible fan ctrl output | (Yes prfFan) with (compatible ctrl (Control.mkDual ctrl))
      compatible fan ctrl output | (Yes prfFan) | Yes prfCtrl = Yes (CompatMux fan ctrl output prfCtrl prfFan)

      compatible fan ctrl output | (Yes prfFan) | No msg contra
        = No (CtrlNotSafe (Control.mkDual ctrl) msg) (ctrlNotCompat contra)
    compatible fan ctrl output | No msg contra
      = No (MuxNotSafe msg) (faninNotCompat contra)

-- [ EOF ]


module ITree
import Control.Monad.State

-- Based on https://arxiv.org/pdf/1906.00046.pdf

data ITree : (e : Type -> Type) -> (r : Type) -> Type where
  Ret : r -> ITree e r
  Tau : Inf (ITree e r) -> ITree e r
  Vis : e a -> (a -> Inf (ITree e r)) -> ITree e r

implementation Functor (ITree e) where
  map f (Ret x) = Ret $ f x
  map f (Tau tr) = Tau $ map f tr
  map f (Vis e k) = Vis e (\x => map f (k x))

implementation Applicative (ITree e) where
  pure a = Ret a

  (Ret f) <*> tra = map f tra
  (Tau trf) <*> tra = Tau $ trf <*> tra
  (Vis e k) <*> tra = Vis e (\x => k x <*> tra)

implementation Monad (ITree e) where
  (Ret r) >>= f = f r
  (Tau tr) >>= f = Tau $ tr >>= f
  (Vis e f') >>= f = Vis e (\x => f' x >>= f)

interface Monad m => MonadIter (m : Type -> Type) where
  iter : (a -> m (Either a b)) -> a -> m b

implementation MonadIter (ITree e) where
  iter body a = do {
                  ab <- body a;
                  case ab of
                    Left a => Tau $ iter body a
                    Right b => Ret b
                }

implementation MonadIter m => MonadIter (StateT s m) where
  iter body a = ST $ \s => iter (\(a, s) =>
    do {
      (ab, s) <- runStateT (body a) s
      pure $ case ab of
              Left a => Left (a, s)
              Right b => Right (b, s)
    }) (a, s)

interp : MonadIter m => ({r : Type} -> e r -> m r) -> {r : Type} -> ITree e r -> m r
interp h = iter (\tr => case tr of
                          Ret r => pure $ Right r
                          Tau tr => pure $ Left tr
                          Vis e k => h e >>= (\x => pure $ Left (k x)))

data IO' : Type -> Type where
  Input : IO' Nat
  Output : Nat -> IO' ()

spin : ITree IO' ()
spin = Tau spin

kill9 : ITree IO' ()
kill9 = Vis Input (\x => if x == 9 then Ret () else kill9)

data StateE : (s : Type) -> Type -> Type where
  Get : StateE s s
  Put : s -> StateE s ()

handlerState : StateE s r -> StateT s (ITree e) r
handlerState Get = ST $ \s => Ret (s, s)
handlerState (Put s') = ST $ \s => Ret ((), s')

interpState : MonadIter m => ({r : Type} -> e r -> StateT s m r) -> ITree e r -> StateT s m r
interpState h = interp h


module FLK_sos

import FLK_ast
import Data.SortedMap

-- operational semanitcs for FLK
-- TODO: Need way to have abstractions step
mutual
  infixr 5 >==> -- read like => in SOS-land
  (>==>) : (CF a) -> (CF b) -> Type
  l >==> r = Step l r

  syntax "[" [ex1] "=>" [ex2] "]"=
    ex1 >- _ `Step` ex2 >- _

  syntax "[" [ex1] "," [env1] "=>" [ex2] "," [env2] "]"=
    ex1 >- env1 `Step` ex2 >- env2

  data Step  : (CF a) -> (CF b) -> Type where
    PNot     :  [Prim1 Not (B b), e => B (not b),  e]

    PrimStep :  [b => b']
             -> [Prim1 o b, e => Prim1 o b', e]

    ArithOp  :  {o : Op2 Arith}
             -> [Prim2 o (N n1) (N n2), e => N (arithOp o n1 n2), e]

    RelOp    :  {o : Op2 Rel}
             -> [Prim2 o (N b1) (N b2), e => B (relop o b1 b2), e]

    GenOp    :  {o : Op2 Gen} -> {op1 : Exp Done} -> {op2 : Exp Done}
             -> [Prim2 o op1 op2, e => genOp o op1 op2, e]

    Prim2L   :  [b => b']
             -> [Prim2 o b re, e => Prim2 o b' re, e]

    Prim2R   :  {le : Exp Done}
             -> [b => b']
             -> [Prim2 o le b, e => Prim2 o le b', e]

    IfCase   :  [b => b']
             -> [If b t f, e' => If b' t f, e']

    IfT      :  [If (B True) t f, e => t, e]

    IfF      :  [If (B False) t f, e => f, e]

    ClosLam  :  [Abs ident exp, e => Clos e (Abs ident exp), e]

    AppFunT  :  [b => b']
             -> [App b exp, e => App b' exp, e]

    AppArgT  :  [arg => arg']
             -> [App (Clos env lam) arg, e => App (Clos env lam) arg', e]

    AppLam   :  {val : Exp Done}
             -> [App (Clos env (Abs ident body)) val, e => body, insert ident (Left val) env]

    IdTrans  :  {e : Env} -> {n : Ident}
             -> Sigma (Exp Done) (\v => lookup n e = (Just (Left v)))
             -> [(Id n), e => v, e]

    IdRecTrans :  {e : Env} -> {n : Ident}
              -> Sigma (Exp RecLam) (\v => lookup n e = (Just (Right v)))
              -> [(Id n), e => v, e]

    RecTrans :  [(Rec ident exp), e => exp, insert ident (Right $ Rec ident exp) e]

  syntax "[[" [str] "," [sub] "]]" = str++" ["++(show sub)++"]";

  instance Show (Step a b) where
    show PNot = "PNot"
    show (PrimStep w) = [["PrimStep", w]]
    show ArithOp = "ArithOp"
    show RelOp = "RelOp"
    show GenOp = "GenOp"
    show (Prim2L t) = [["Prim2L", t]]
    show (Prim2R s) = [["Prim2R", s]]
    show (IfCase s) = [["IfCase", s]]
    show IfT = "IfT"
    show IfF = "IfF"
    show ClosLam = "ClosLam"
    show (AppFunT s) = [["AppFunT", s]]
    show (AppArgT z) = [["AppArgT", z]]
    show AppLam = "AppLam"
    show (IdTrans x) = "IdTrans"
    show (IdRecTrans x) = "IdRecTrans"
    show RecTrans = "RecTrans"

-- Simple rule application
testStep1 : Prim1 Not (B True) >- e >==> (B False) >- e
testStep1 = PNot

-- Compose two rules
testStep : [(Prim1 Not (Prim1 Not (B False))), e => Prim1 Not (B True), e]
testStep {e=e} = PrimStep $ PNot {e=e}

takeStep : {state' : CF b} -> {rule : state >==> state'} -> (state : CF a) ->  CF b
takeStep {state' = s} _ = s

default : Exp a -> CF a
default x = x >- emptyEnv

opResolve : {e : Env}
         -> (op : Op2 a)
         -> (o1 : Exp Done)
         -> (o2 : Exp Done)
         -> Maybe (Sigma (Exp Done) (\state => Step ((Prim2 op o1 o2) >- e) (state >- e)))
opResolve EQ op1 op2 = Just ((genOp EQ op1 op2) ** GenOp)
opResolve NEQ op1 op2 = Just ((genOp NEQ op1 op2) ** GenOp)
opResolve Plus (N k) (N z) =  Just ((N $ arithOp Plus k z) ** ArithOp)
opResolve Minus (N k) (N z) = Just ((N $ arithOp Minus k z) ** ArithOp)
opResolve LThan (N k) (N z) =  Just ((B $ relop LThan k z) ** RelOp)
opResolve LEThan (N k) (N z) = Just ((B $ relop LEThan k z) ** RelOp)
opResolve GThan (N k) (N z) =  Just ((B $ relop GThan k z) ** RelOp)
opResolve GEThan (N k) (N z) =  Just ((B $ relop GEThan k z) ** RelOp)
opResolve x x1 x2 = Nothing

mutual
  -- Evaluator based on operational semantics
  -- TODO: add printing, with effects and such
  goTill : Sigma Status (\s => CF s) -> Sigma Status (\s' => CF s')
  goTill (MkSigma Inter pf) with (search pf)
    goTill (MkSigma Inter pf) | Nothing = MkSigma Inter pf
    goTill (MkSigma Inter pf) | (Just (MkSigma x (MkSigma y z))) = goTill $ MkSigma x y
  goTill p@(MkSigma Done pf) = p
  goTill (MkSigma Lam pf) with (searchLam pf)
    goTill (MkSigma Lam pf) | Nothing = (MkSigma Lam pf)
    goTill (MkSigma Lam pf) | (Just (MkSigma x (MkSigma y z))) = goTill $ MkSigma x y
  goTill (MkSigma RecLam pf) = let (x ** (y ** z)) = recTrans pf in goTill (x ** y)

  -- Search rules for the semantics
  -- Forall states, we get
  --      Maybe (exists a Status such that there exists a state with
  --            that status that is transitioned to by the state)
  search : (start : CF Inter) -> Maybe (Sigma Status (\s => (Sigma (CF s) (\o => Step start o))))
  search ((App z w) >- y)     = search_app y z w
  search ((If z w s) >- y)    = search_if z w s y
  search ((Prim1 z w) >- y)   = search_prim1 z w y
  search ((Prim2 z w s) >- y) = search_prim2 z w s y
  search ((Id x) >- y) with (idSteps x y)
    search ((Id x) >- y) | Nothing with (idRecSteps x y)
      search ((Id x) >- y) | Nothing | Nothing = Nothing
      search ((Id x) >- y) | Nothing | (Just (v ** pf)) =
        Just $ (RecLam ** (v >- y ** IdRecTrans (v ** pf)))
    search ((Id x) >- y) | Just (v ** pf) = Just $ (Done ** (v >- y ** IdTrans (v ** pf)))

  -- This is a macro that will do most of the intermediate computations needed for some common
  -- lemmas
  -- My understanding is that this sort of thing should be done with a high-level tactic
  -- involving reflection. I do not fully understand how to use this feature, so I am using the
  -- 'syntax' feature as a macro system of sorts
  syntax "[[" {state} "," {trans} "," [env] "," [ex] "," [newstate] "," [rule] "]]" =
               case (search $ ex >- env) of {
                 Nothing => Nothing ;
                 Just (status ** (state >- y' ** trans)) =>
                      Just (Inter ** (newstate >- env ** rule));
               }

  -- transition intermediate-result composite expressions. wrapper for above macro
  syntax "[[" [env] ";" [ex] ";" [newstate] ";" [rule] "]]" =
    [[ state, trans, env, ex, (newstate state), (rule trans)]]

  -- transition abstractions
  syntax "<[" [trans] "," [abs] "," [env] "," [state] "]>" =
    Just $ (_ ** (((state (Clos env abs)) >- env) ** trans ClosLam));
  -- transition rec expressions
  syntax "<[" [trans] ";" [rec] ";" [env] ";" [state] "]>" =
    let (tag ** (newstate >- env' ** newtrans)) = recTrans (rec >- env) in
        Just $ (_ ** ((state newstate) >- env ** trans newtrans));

  search_prim2_rhs_7 : (z : Op2 y)
                    -> (exp : Exp Done)
                    -> (s : Exp b)
                    -> (y : SortedMap String (Either (Exp Done) (Exp RecLam)))
                    -> Maybe (Sigma Status (\s2 => Sigma (CF s2)
                                   (\o => Step ((Prim2 z exp s) >- y) o)))
  search_prim2_rhs_7 z exp (App x w) y = [[y; (App x w); Prim2 z exp; Prim2R]]
  search_prim2_rhs_7 z exp (Abs x w) y = <[Prim2R, (Abs x w), y, Prim2 z exp]>
  search_prim2_rhs_7 z exp (Rec x w) y = <[Prim2R; (Rec x w); y; Prim2 z exp]>
  search_prim2_rhs_7 z exp (If x w s) y = [[y; If x w s; Prim2 z exp; Prim2R]]
  search_prim2_rhs_7 z exp (Prim1 x w) y = [[y; Prim1 x w; Prim2 z exp; Prim2R]]
  search_prim2_rhs_7 z exp (Prim2 w s t) y = [[y; Prim2 w s t; Prim2 z exp; Prim2R]]
  search_prim2_rhs_7 z exp (Id x) y = [[y; Id x; Prim2 z exp; Prim2R]]
  search_prim2_rhs_7 z exp (N k) y with (opResolve {e=y} z exp (N k))
    search_prim2_rhs_7 z exp (N k) y | Nothing = Nothing
    search_prim2_rhs_7 z exp (N k) y | (Just (exp ** step)) = Just (Done ** (exp >- y ** step))
  search_prim2_rhs_7 z exp (B x) y with (opResolve {e=y} z exp (B x))
    search_prim2_rhs_7 z exp (B x) y | Nothing = Nothing
    search_prim2_rhs_7 z exp (B x) y | (Just (exp ** step)) = Just (Done ** (exp >- y ** step))
  search_prim2_rhs_7 z exp (Clos x w) y with (opResolve {e=y} z exp (Clos x w))
    search_prim2_rhs_7 z exp (Clos x w) y | Nothing = Nothing
    search_prim2_rhs_7 z exp (Clos x w) y | (Just (exp ** step)) = Just (Done ** (exp >- y ** step))

  search_prim2 : (z : Op2 y)
              -> (w : Exp a)
              -> (s : Exp b)
              -> (y : SortedMap String (Either (Exp Done) (Exp RecLam)))
              -> Maybe (Sigma Status (\s1 => Sigma (CF s1)
                                             (\o => Step ((Prim2 z w s) >- y) o)))
  search_prim2 z (App x w) s y = [[y; (App x w); \st => Prim2 z st s; Prim2L]]
  search_prim2 z (Abs x w) s y = <[Prim2L, (Abs x w), y, \st => Prim2 z st s]>
  search_prim2 z (Rec x w) s y = <[Prim2L; (Rec x w); y; \st => Prim2 z st s]>
  search_prim2 z (If x w t) s y = [[y; If x w t; \st => Prim2 z st s; Prim2L]]
  search_prim2 z (Prim1 x w) s y = [[y; Prim1 x w; \st => Prim2 z st s; Prim2L]]
  search_prim2 z (Prim2 w t u) s y = [[y; Prim2 w t u; \st => Prim2 z st s; Prim2L]]
  search_prim2 z (Id x) s y = [[y; Id x; \st => Prim2 z st s; Prim2L]]
  search_prim2 z (N k) s y = search_prim2_rhs_7 z (N k) s y
  search_prim2 z (B x) s y = search_prim2_rhs_7 z (B x) s y
  search_prim2 z (Clos x w) s y = search_prim2_rhs_7 z (Clos x w) s y

  total
  searchLam : (start : CF Lam)
           -> Maybe (Sigma Status (\s => (Sigma (CF s) (\o => Step start o))))
  searchLam ((Abs x z) >- y) = <[ id , (Abs x z), y, id ]>

  total
  recTrans : (start : CF RecLam)
          -> (Sigma Status (\s => (Sigma (CF s) (\o => Step start o))))
  recTrans ((Rec x z) >- y) = (getTag z ** (z >- (insert x (Right $ Rec x z) y) ** RecTrans))

  total
  searchRec : (start : CF RecLam)
           -> Maybe (Sigma Status (\s => (Sigma (CF s) (\o => Step start o))))
  searchRec r = Just $ recTrans r

  search_if : (z : Exp a)
           -> (w : Exp b)
           -> (s : Exp c)
           -> (y : Env)
           -> Maybe (Sigma Status (\s1 => Sigma (CF s1) (\o => Step ((If z w s) >- y) o)))
  search_if (Abs x z) w s y  = <[IfCase, (Abs x z), y, \c => If c w s]> --Nothing
  search_if (Rec i b) w s y  = <[IfCase; (Rec i b); y; \c => If c w s]>
  search_if (N _) _ _ _      = Nothing
  search_if (Clos _ _) _ _ _ = Nothing
  search_if (B x) w s y = case x of
                               True  => let t = getTag w in
                                            Just (t ** (w >- y ** IfT))
                               False => let t = getTag s in
                                            Just (t ** (s >- y ** IfF))
  search_if (App lam st)  w s y = [[state, trans, y, App lam st, If state w s , IfCase trans]]
  search_if (If x z t)    w s y = [[y; (If x z t); \state => If state w s; IfCase]]
  search_if (Prim1 x z)   w s y = [[y; (Prim1 x z); \state => If state w s; IfCase]]
  search_if (Prim2 x z t) w s y = [[y; (Prim2 x z t); \state => If state w s; IfCase]]
  search_if (Id x)        w s y = [[y; (Id x); \state => If state w s; IfCase]]

  search_prim1 : (z : Op1)
              -> (w : Exp a)
              -> (y : Env)
              -> Maybe (Sigma Status (\s => Sigma (CF s) (\o => Step ((Prim1 z w) >- y) o)))
  search_prim1 Not (Abs x z)  y = <[PrimStep, (Abs x z), y, (Prim1 Not)]>
  search_prim1 Not (Rec x z)  y = <[PrimStep; (Rec x z); y; (Prim1 Not)]>
  search_prim1 Not (N k)      y = Nothing
  search_prim1 Not (Clos x z) y = Nothing
  search_prim1 Not (B x) y = Just $ (Done ** (B (not x) >- y ** PNot))
  search_prim1 Not (App x z)     y = [[y; (App x z); Prim1 Not; PrimStep]]
  search_prim1 Not (If x z w)    y = [[y; (If x z w); Prim1 Not; PrimStep]]
  search_prim1 Not (Prim1 x z)   y = [[y; (Prim1 x z); Prim1 Not; PrimStep]]
  search_prim1 Not (Prim2 z w s) y = [[y; (Prim2 z w s); Prim1 Not; PrimStep]]
  search_prim1 Not (Id x)        y = [[y; (Id x); Prim1 Not; PrimStep]]

  search_subst_env : (y : Env) -- Outer environment
                  -> (x : Env) -- Closure environment
                  -> (z : Exp Lam)
                  -> (k : Exp Done)
                  -> Maybe (Sigma Status
                                 (\s => Sigma (CF s)
                                              (\o => Step ((App (Clos x z) k) >- y) o)))
  search_subst_env y x (Abs iden w) k =
    Just $ (getTag w ** (w >- (insert iden (Left k) x) ** AppLam))

  search_app : (y : Env)
            -> (z : Exp a)
            -> (w : Exp b)
            -> Maybe (Sigma Status (\s => Sigma (CF s) (\o => Step ((App z w) >- y) o)))
  search_app y p@(Abs id body) w  = <[AppFunT, (Abs id body), y, (\clos => App clos w)]>
  search_app y (App e b)        w = [[y; (App e b); \s => App s w; AppFunT]]
  search_app y (If c t f)       w = [[y; (If c t f); \s => App s w; AppFunT]]
  search_app y (Prim1 op oa)    w = [[y; (Prim1 op oa); \s => App s w; AppFunT]]
  search_app y (Prim2 op o1 o2) w = [[y; (Prim2 op o1 o2); \s => App s w; AppFunT]]
  search_app y (Id x)           w = [[y; (Id x); \s => App s w; AppFunT]]
  search_app y (N k)            w = Nothing
  search_app y (B x)            w = Nothing
  search_app y (Rec x z)        w   = <[AppFunT; (Rec x z); y; (\clos => App clos w)]>
  search_app y (Clos x z) (Rec w s) = <[AppArgT; (Rec w s); y; (\arg => App (Clos x z) arg)]>
  search_app y (Clos x z) (App e b)        = [[y; App e b; App (Clos x z); AppArgT]]
  search_app y (Clos x z) (If c t f)       = [[y; If c t f; App (Clos x z); AppArgT]]
  search_app y (Clos x z) (Prim1 op oa)    = [[y; Prim1 op oa; App (Clos x z); AppArgT]]
  search_app y (Clos x z) (Prim2 op o1 o2) = [[y; Prim2 op o1 o2; App (Clos x z); AppArgT]]
  search_app y (Clos x z) (Id i)           = [[y; Id i; App (Clos x z); AppArgT]]
  search_app y (Clos x z) p@(Abs _ _)      = Just $ (Inter **
                                                     (App (Clos x z) (Clos y p) >- y **
                                                       AppArgT ClosLam))
  search_app y (Clos x z) p@(N k)          = search_subst_env y x z p
  search_app y (Clos x z) p@(B w)          = search_subst_env y x z p
  search_app y (Clos x z) p@(Clos w s)     = search_subst_env y x z p


data A = B | B

data C : Type -> Type where
  D : C Int
  D : C String


module IntEqOrd

public export
Eq Int8 where
  x == y = intToBool (prim__eq_Int8 x y)

public export
Eq Int16 where
  x == y = intToBool (prim__eq_Int16 x y)

public export
Eq Int32 where
  x == y = intToBool (prim__eq_Int32 x y)

public export
Eq Int64 where
  x == y = intToBool (prim__eq_Int64 x y)

public export
Ord Int8 where
  compare x y = if x < y then LT else if x == y then EQ else GT

  (<) x y = intToBool (prim__lt_Int8 x y)
  (<=) x y = intToBool (prim__lte_Int8 x y)
  (>) x y = intToBool (prim__gt_Int8 x y)
  (>=) x y = intToBool (prim__gte_Int8 x y)

public export
Ord Int16 where
  compare x y = if x < y then LT else if x == y then EQ else GT

  (<) x y = intToBool (prim__lt_Int16 x y)
  (<=) x y = intToBool (prim__lte_Int16 x y)
  (>) x y = intToBool (prim__gt_Int16 x y)
  (>=) x y = intToBool (prim__gte_Int16 x y)

public export
Ord Int32 where
  compare x y = if x < y then LT else if x == y then EQ else GT

  (<) x y = intToBool (prim__lt_Int32 x y)
  (<=) x y = intToBool (prim__lte_Int32 x y)
  (>) x y = intToBool (prim__gt_Int32 x y)
  (>=) x y = intToBool (prim__gte_Int32 x y)

public export
Ord Int64 where
  compare x y = if x < y then LT else if x == y then EQ else GT

  (<) x y = intToBool (prim__lt_Int64 x y)
  (<=) x y = intToBool (prim__lte_Int64 x y)
  (>) x y = intToBool (prim__gt_Int64 x y)
  (>=) x y = intToBool (prim__gte_Int64 x y)


libcb : String -> String
libcb f = "C:" ++ f ++", libcb"

%foreign libcb "add"
add : Int -> Int -> Int

%foreign libcb "applyIntFn"
prim_applyIntFn : Int -> Int -> (Int -> Int -> PrimIO Int) -> PrimIO Int

%foreign libcb "applyCharFn"
prim_applyCharFn : Char -> Int -> (Char -> Int -> PrimIO Char) -> PrimIO Char

%foreign libcb "applyIntFnPure"
applyIntFnPure : Int -> Int -> (Int -> Int -> Int) -> Int

applyIntFn : Int -> Int -> (Int -> Int -> IO Int) -> IO Int
applyIntFn x y fn
    = primIO $ prim_applyIntFn x y (\a, b => toPrim (fn a b))

applyCharFn : Char -> Int -> (Char -> Int -> IO Char) -> IO Char
applyCharFn x y fn
    = primIO $ prim_applyCharFn x y (\a, b => toPrim (fn a b))

cb : Int -> Int -> IO Int
cb x y
    = do putStrLn $ "In callback with " ++ show (x, y)
         pure (x + y)

main : IO ()
main
    = do printLn (add 4 5)
         res <- applyIntFn (add 4 5) 6 (\x, y => do putStrLn "In callback"
                                                    pure (x * 2 + y))
         printLn res
         res <- applyIntFn 1 2 cb
         printLn res
         printLn (applyIntFnPure 5 4 (\x, y => x + y))
         res <- applyCharFn 'a' 10 (\x, y => pure (cast (cast x + y)))
         printLn res


module InfoWithImplicit

import public Language.Reflection.Pretty
import public Language.Reflection.Syntax
import public Language.Reflection.Types
import Data.Vect

import Mb

%language ElabReflection

data X : Vect n a -> Type where
  XX : X []

export
inf : TypeInfo
inf = getInfo "X"

export
mbInf : TypeInfo
mbInf = getInfo "T"
-- `T` and its constructors are visible even when they are not exported


module Calc.Div

%default total

export
divide : Int -> Int -> Int
divide x y = if y == 0
             then 0
             else x `div` y


module Main

import IdrisJvm.IO
import Java.Lang

mutual
  evenT : Nat -> JVM_IO ()
  evenT Z = printLn True
  evenT (S k) = do
    setProperty "bar" (show k)
    oddT k

  oddT : Nat -> JVM_IO ()
  oddT Z = printLn False
  oddT (S k) = do
    setProperty "foo" (show k)
    evenT k

main : JVM_IO ()
main = evenT 99999


module Main

import Effect.StdIO
import VectMissing

-----------------------------------------------------------------------
-- GAME STATE
-----------------------------------------------------------------------

{- First, the game state, HState, where the type specifies how many guesses
are left and how many missing letters there are still to get. -}

data HState : Nat -> Nat -> Type where
     MkH : (word : String) ->
           (guesses : Nat) ->
           (got : List Char) ->
           (missing : Vect m Char) ->
           HState guesses m

instance Default (HState 0 0) where
    default = MkH "" 0 [] []

instance Show (HState guesses m) where
    show (MkH w _ got missing)
         = let w' = pack (map showGot (unpack w)) in
               w' ++ "\n\n" ++ show guesses ++ " guesses left"
      where showGot : Char -> Char
            showGot ' ' = '/'
            showGot c = if ((not (isAlpha c)) || (c `elem` got)) then c else '-'

{- Initialise the state with the missing letters in a word -}

total
letters : String -> List Char
letters x with (strM x)
  letters "" | StrNil = []
  letters (strCons y xs) | (StrCons y xs)
          = let xs' = assert_total (letters xs) in
                if ((not (isAlpha y)) || (y `elem` xs')) then xs' else y :: xs'

initState : (x : String) -> HState 6 (length (letters x))
initState w = let xs = letters w in
                  MkH w _ [] (fromList (letters w))

-----------------------------------------------------------------------
-- RULES
-----------------------------------------------------------------------

{- Now, the rules of the game, written as an Effect.
We can think of the rules as giving a protocol that the game player and
the machine must follow for an implementation of the game to make sense.
-}

data Hangman : Effect where

-- Rule:
-- Precondition: we can make a guess if we have one or more guess available
-- (S g) and one or more letters are still missing (S w)

-- Postcondition: return whether the character was in the word. If so, reduce
-- the number of missing letters, if not, reduce the number of guesses left

     Guess : (x : Char) ->
             { HState (S g) (S w) ==>
               {inword} if inword then HState (S g) w
                                  else HState g (S w) }
                Hangman Bool

-- The 'Won' operation requires that there are no missing letters

     Won  : { HState g 0 ==> HState 0 0 } Hangman ()

-- The 'Lost' operation requires that there are no guesses left

     Lost : { HState 0 w ==> HState 0 0 } Hangman ()

-- Set up a new game, initialised with 6 guesses and the missing letters in
-- the given word. Note that if there are no letters in the word, we won't
-- be able to run 'Guess'!

     NewWord : (w : String) ->
               { h ==> HState 6 (length (letters w)) } Hangman ()

-- Finally, allow us to get the current game state

     Get  : { h } Hangman h

HANGMAN : Nat -> Nat -> EFFECT
HANGMAN g v = MkEff (HState g v) Hangman

-----------------------------------------------------------------------
-- IMPLEMENTATION OF THE RULES
-----------------------------------------------------------------------

{- This effect handler simply updates the game state as necessary for
each operation. 'Guess' is slightly tricky, in that it needs to check
whether the letter is in the word, and branch accordingly (and if it
is in the word, update the vector of missing letters to be the right
length). -}

using (m : Type -> Type)
  instance Handler Hangman m where
    handle (MkH w g got []) Won k = k () (MkH w 0 got [])
    handle (MkH w Z got m) Lost k = k () (MkH w 0 got [])

    handle st Get k = k st st
    handle st (NewWord w) k = k () (initState w)

    handle (MkH w (S g) got m) (Guess x) k =
      case isElem x m of
           Nothing => k False (MkH w _ got m)
           (Just p) => k True (MkH w _ (x :: got) (shrink m p))

-----------------------------------------------------------------------
-- USER INTERFACE
-----------------------------------------------------------------------

{- Finally, an implementation of the game which reads user input and calls
the operations we defined above when appropriate -}

game : { [HANGMAN (S g) (S w), STDIO] ==> [HANGMAN 0 0, STDIO] } Eff IO ()
game = do putStrLn (show !Get)
          putStr "Enter guess: "
          let guess = trim !getStr
          case choose (not (guess == "")) of
               (Left p) => processGuess (strHead' guess p)
               (Right p) => do putStrLn "Invalid input!"
                               game
  where
    processGuess : Char -> { [HANGMAN (S g) (S w), STDIO] ==>
                             [HANGMAN 0 0, STDIO] }
                           Eff IO ()
    processGuess {g} {w} c
      = case !(Main.Guess c) of
             True => do putStrLn "Good guess!"
                        case w of
                             Z => Won
                             (S k) => game
             False => do putStrLn "No, sorry"
                         case g of
                              Z => Lost
                              (S k) => game

{- It typechecks! Ship it! -}

runGame : { [HANGMAN 0 0, STDIO] } Eff IO ()
runGame = do NewWord "sausage machine"
             game

{- I made a couple of mistakes while writing this. For example, the following
were caught by the type checker:

* Forgetting to check the 'Won' state before continuing with 'game'
* Accidentally checking the number of missing letters rather than the number
  of guesses when checking if 'Lost' was callable

-}

main : IO ()
main = run runGame


module Flexidisc.Header.Sub

import Flexidisc.Header.Label
import Flexidisc.Header.Row
import Flexidisc.Header.Type
import Flexidisc.OrdList

%default total
%access public export

data Sub : (xs, ys : Header' k a) -> Type where
  S : {xs : OrdList k o a} -> {ys : OrdList k o a} ->
      Sub xs ys -> Sub (H xs) (H ys)

%hint
public export
rowFromSub : Sub xs ys -> Row key ty xs -> Row key ty ys
rowFromSub (S sub) (R lbl) = R (rowFromSub sub lbl)

%hint
public export
labelFromSub : Sub xs ys -> Label x xs -> Label x ys
labelFromSub (S sub) (L lbl) = L (labelFromSub sub lbl)


module Effekt.IteratedUnstaged

import Effekt.CpsUnstaged

public export
Stm : List Type -> Type -> Type
Stm [] a = a
Stm (r :: rs) a = Cps (Stm rs r) a

pure : a -> Stm rs a
pure{  rs= []}         a = a
pure{  rs= r :: rs}  a = \k => k a

push : (a -> Stm (r :: rs) b) -> (b -> Stm rs r) -> (a -> Stm rs r)
push f k = \a => f a k

bind : Stm rs a -> (a -> Stm rs b) -> Stm rs b
bind{  rs= []}         m f = f m
bind{  rs= r :: rs}  m f = \k => m (push f k)

(>>=) : Stm rs a -> (a -> Stm rs b) -> Stm rs b
(>>=) = bind

lift : Stm rs a -> Stm (r :: rs) a
lift = bind

shift0 : ((a -> Stm rs r) -> Stm rs r) -> Stm (r :: rs) a
shift0 = id

runIn0 : Stm (r :: rs) a -> (a -> Stm rs r) -> Stm rs r
runIn0 = id

reset0 : Stm (a :: rs) a -> Stm rs a
reset0 m = runIn0 m pure

shift00 : ((a -> Stm rs r) -> Stm rs r) -> Stm (r :: rs) a
shift00 k = shift0 k

shift01 : ((a -> Stm rs r) -> Stm rs r) -> Stm (q :: r :: rs) a
shift01 {r} {rs} k = lift {rs = r::rs} (shift0 {r} {rs} k)

shift02 : ((a -> Stm rs r) -> Stm rs r) -> Stm (p :: q :: r :: rs) a
shift02 {q} {r} {rs} k = lift {rs = q::r::rs} (lift {rs = r::rs} (shift0 {r} {rs} k))

reset01 : Stm (a :: a :: rs) a -> Stm rs a
reset01 {a} {rs} m = reset0 (reset0 {rs=(a :: rs)} m)

shift : ((a -> Stm (r :: rs) r) -> Stm (r :: rs) r) -> Stm (r :: rs) a
shift {r} {rs} body = shift0 (\k => reset0 (body (\a => lift {r} {rs} (k a))))

emit : Int -> Stm (List Int :: rs) ()
emit {rs} a = shift0 {rs} (\c =>
  bind {rs} (c ()) (\as =>
  pure {rs} (the (Int -> List Int -> List Int) (::) a as)))

partition : Int -> List Int -> Stm [List Int, List Int] ()
partition a l = case l of
  [] => do
    pure {rs=[List Int,List Int]} ()
  (h :: t) => if (a < h)
    then (
      bind {rs=[List Int,List Int]} (emit {rs=[List Int]} h) (\u =>
      partition a t))
    else (
      bind {rs=[List Int,List Int]} (lift {rs=[List Int]} (emit {rs=[]} h)) (\u =>
      partition a t))


module Test.Optics

import UnitTest
import Data.Optics
import Control.Category

PLZ : Type
PLZ = Integer

mutual
  record Person where
    constructor MkPerson
    name : String
    address : Address
    second : Maybe Address

  record Address where
    constructor MkAddress
    street: String
    plz : PLZ
    city : String

  instance Eq Person where
    (==) (MkPerson name address second) (MkPerson x y z) = (name == x) && (address == y) && (second == z)

  instance Eq Address where
    (==) (MkAddress street plz city) (MkAddress x y z) = (street == x) && (plz == y) && (city == z)

  instance Show Person where
    show p = "Person(" ++ name p ++ ")"

  instance Show Address where
    show a = "Address(" ++ street a ++ ")"

hamburg: Address
hamburg = MkAddress "Elbchaussee" 2000 "Hamburg"

p: Person
p = MkPerson "Holmes" hamburg (Just hamburg)

_name : Lens Person String
_name = MkLens (\p => name p) (\p,n => record { name = n} p)

_address : Lens Person Address
_address = MkLens (\p => address p) (\p, a => record { address = a} p)

_secondary_address : Optional Person Address
_secondary_address = MkOptional (\p => second p) (\p, a => record { second = Just a} p )

_street : Lens Address String
_street = MkLens (\a => street a) (\a, s => record { street = s} a)

_person_street : Lens Person String
_person_street =  _address >>> _street

_secondary_street : Optional Person String
_secondary_street = _secondary_address +:? lensAsOptional _street

testPersonNameGet : IO ()
testPersonNameGet = assertEq "the _name lens can get the name of a person" (get _name p) ("Holmes")

testPersonNameSet : IO ()
testPersonNameSet = assertEq "the _name lens can set the name of a person" (set _name p "Watson") ( record { name = "Watson"} p)

testPersonAddressStreetGet : IO ()
testPersonAddressStreetGet = assertEq "the composed _person_street lens can get the name of the street" (get _person_street p) ("Elbchaussee")

testModifyF : IO ()
testModifyF = assertEq "modifyF can modify a value using a functor"(modifyF (\n => Just n) _name p) (Just p)

runall : IO()
runall = do testPersonNameGet
            testPersonNameSet
            testPersonAddressStreetGet
            testModifyF


module Main

import NBody
import Data.Vect
import System
import Prelude.Providers
import Data.String

main : IO ()
main = nbodyFunc


module LightClick.Types.WireType

import Decidable.Equality

import Toolkit.Decidable.Informative

%default total

public export
data Wire : Type where
   Data      : Wire
   Address   : Wire
   Clock     : Wire
   Reset     : Wire
   Info      : Wire
   Interrupt : Wire
   Control   : Wire
   General   : Wire

dataNotAddress : (Data = Address) -> Void
dataNotAddress Refl impossible

dataNotClock : (Data = Clock) -> Void
dataNotClock Refl impossible

dataNotReset : (Data = Reset) -> Void
dataNotReset Refl impossible

dataNotInfo : (Data = Info) -> Void
dataNotInfo Refl impossible

dataNotInterrupt : (Data = Interrupt) -> Void
dataNotInterrupt Refl impossible

dataNotControl : (Data = Control) -> Void
dataNotControl Refl impossible

dataNotGeneral : (Data = General) -> Void
dataNotGeneral Refl impossible

addressNotClock : (Address = Clock) -> Void
addressNotClock Refl impossible

addressNotReset : (Address = Reset) -> Void
addressNotReset Refl impossible

addressNotInfo : (Address = Info) -> Void
addressNotInfo Refl impossible

addressNotInterrupt : (Address = Interrupt) -> Void
addressNotInterrupt Refl impossible

addressNotControl : (Address = Control) -> Void
addressNotControl Refl impossible

addressNotGeneral : (Address = General) -> Void
addressNotGeneral Refl impossible

clockNotReset : (Clock = Reset) -> Void
clockNotReset Refl impossible

clockNotInfo : (Clock = Info) -> Void
clockNotInfo Refl impossible

clockNotInterrupt : (Clock = Interrupt) -> Void
clockNotInterrupt Refl impossible

clockNotControl : (Clock = Control) -> Void
clockNotControl Refl impossible

clockNotGeneral : (Clock = General) -> Void
clockNotGeneral Refl impossible

resetNotInfo : (Reset = Info) -> Void
resetNotInfo Refl impossible

resetNotInterrupt : (Reset = Interrupt) -> Void
resetNotInterrupt Refl impossible

resetNotControl : (Reset = Control) -> Void
resetNotControl Refl impossible

resetNotGeneral : (Reset = General) -> Void
resetNotGeneral Refl impossible

infoNotInterrupt : (Info = Interrupt) -> Void
infoNotInterrupt Refl impossible

infoNotControl : (Info = Control) -> Void
infoNotControl Refl impossible

infoNotGeneral : (Info = General) -> Void
infoNotGeneral Refl impossible

interruptNotControl : (Interrupt = Control) -> Void
interruptNotControl Refl impossible

interruptNotGeneral : (Interrupt = General) -> Void
interruptNotGeneral Refl impossible

controlNotGeneral : (Control = General) -> Void
controlNotGeneral Refl impossible

export
DecEq Wire where
  decEq Data Data = Yes Refl
  decEq Data Address = No dataNotAddress
  decEq Data Clock = No dataNotClock
  decEq Data Reset = No dataNotReset
  decEq Data Info = No dataNotInfo
  decEq Data Interrupt = No dataNotInterrupt
  decEq Data Control = No dataNotControl
  decEq Data General = No dataNotGeneral

  decEq Address Data = No (negEqSym dataNotAddress)
  decEq Address Address = Yes Refl
  decEq Address Clock = (No addressNotClock)
  decEq Address Reset = (No addressNotReset)
  decEq Address Info = (No addressNotInfo)
  decEq Address Interrupt = (No addressNotInterrupt)
  decEq Address Control = (No addressNotControl)
  decEq Address General = (No addressNotGeneral)

  decEq Clock Data = No (negEqSym dataNotClock)
  decEq Clock Address = No (negEqSym addressNotClock)
  decEq Clock Clock = Yes Refl
  decEq Clock Reset = No clockNotReset
  decEq Clock Info = No clockNotInfo
  decEq Clock Interrupt = No clockNotInterrupt
  decEq Clock Control = No clockNotControl
  decEq Clock General = No clockNotGeneral

  decEq Reset Data = No (negEqSym dataNotReset)
  decEq Reset Address = No (negEqSym addressNotReset)
  decEq Reset Clock = No (negEqSym clockNotReset)
  decEq Reset Reset = Yes Refl
  decEq Reset Info = No resetNotInfo
  decEq Reset Interrupt = No resetNotInterrupt
  decEq Reset Control = No resetNotControl
  decEq Reset General = No resetNotGeneral

  decEq Info Data = No (negEqSym dataNotInfo)
  decEq Info Address = No (negEqSym addressNotInfo)
  decEq Info Clock = No (negEqSym clockNotInfo)
  decEq Info Reset = No (negEqSym resetNotInfo)
  decEq Info Info = Yes Refl
  decEq Info Interrupt = No infoNotInterrupt
  decEq Info Control = No infoNotControl
  decEq Info General = No infoNotGeneral

  decEq Interrupt Data = No (negEqSym dataNotInterrupt)
  decEq Interrupt Address = No (negEqSym addressNotInterrupt)
  decEq Interrupt Clock = No (negEqSym clockNotInterrupt)
  decEq Interrupt Reset = No (negEqSym resetNotInterrupt)
  decEq Interrupt Info = No (negEqSym infoNotInterrupt)
  decEq Interrupt Interrupt = Yes Refl
  decEq Interrupt Control = No interruptNotControl
  decEq Interrupt General = No interruptNotGeneral

  decEq Control Data = No (negEqSym dataNotControl)
  decEq Control Address = No (negEqSym addressNotControl)
  decEq Control Clock = No (negEqSym clockNotControl)
  decEq Control Reset = No (negEqSym resetNotControl)
  decEq Control Info = No (negEqSym infoNotControl)
  decEq Control Interrupt = No (negEqSym interruptNotControl)
  decEq Control Control = Yes Refl
  decEq Control General = No controlNotGeneral

  decEq General Data = No (negEqSym dataNotGeneral)
  decEq General Address = No (negEqSym addressNotGeneral)
  decEq General Clock = No (negEqSym clockNotGeneral)
  decEq General Reset = No (negEqSym resetNotGeneral)
  decEq General Info = No (negEqSym infoNotGeneral)
  decEq General Interrupt = No (negEqSym interruptNotGeneral)
  decEq General Control = No (negEqSym controlNotGeneral)
  decEq General General = Yes Refl

public export
data Compatible : (l,r : Wire) -> Type
  where
    SameWire : Compatible w       w
    GAny     : Compatible General a
    AnyG     : Compatible a       General

negCompatibleSym : (Compatible l r -> Void) -> Compatible r l -> Void
negCompatibleSym f SameWire = f SameWire
negCompatibleSym f GAny = f AnyG
negCompatibleSym f AnyG = f GAny

daNotCompat : Compatible Data Address -> Void
daNotCompat SameWire impossible
daNotCompat GAny impossible
daNotCompat AnyG impossible

dcNotCompat : Compatible Data Clock -> Void
dcNotCompat SameWire impossible
dcNotCompat GAny impossible
dcNotCompat AnyG impossible

drNotCompat : Compatible Data Reset -> Void
drNotCompat SameWire impossible
drNotCompat GAny impossible
drNotCompat AnyG impossible

ddNotCompat : Compatible Data Info -> Void
ddNotCompat SameWire impossible
ddNotCompat GAny impossible
ddNotCompat AnyG impossible

diNotCompat : Compatible Data Interrupt -> Void
diNotCompat SameWire impossible
diNotCompat GAny impossible
diNotCompat AnyG impossible

dctrlNotCompat : Compatible Data Control -> Void
dctrlNotCompat SameWire impossible
dctrlNotCompat GAny impossible
dctrlNotCompat AnyG impossible

acNotCompat : Compatible Address Clock -> Void
acNotCompat SameWire impossible
acNotCompat GAny impossible
acNotCompat AnyG impossible

arNotCompat : Compatible Address Reset -> Void
arNotCompat SameWire impossible
arNotCompat GAny impossible
arNotCompat AnyG impossible

aiNotCompat : Compatible Address Info -> Void
aiNotCompat SameWire impossible
aiNotCompat GAny impossible
aiNotCompat AnyG impossible

aitNotCompat : Compatible Address Interrupt -> Void
aitNotCompat SameWire impossible
aitNotCompat GAny impossible
aitNotCompat AnyG impossible

actrlNotCompat : Compatible Address Control -> Void
actrlNotCompat SameWire impossible
actrlNotCompat GAny impossible
actrlNotCompat AnyG impossible

crNotCompat : Compatible Clock Reset -> Void
crNotCompat SameWire impossible
crNotCompat GAny impossible
crNotCompat AnyG impossible

ciNotCompat : Compatible Clock Info -> Void
ciNotCompat SameWire impossible
ciNotCompat GAny impossible
ciNotCompat AnyG impossible

cintNotCompat : Compatible Clock Interrupt -> Void
cintNotCompat SameWire impossible
cintNotCompat GAny impossible
cintNotCompat AnyG impossible

ccNotCompatc : Compatible Clock Control -> Void
ccNotCompatc SameWire impossible
ccNotCompatc GAny impossible
ccNotCompatc AnyG impossible

riNotCompat : Compatible Reset Info -> Void
riNotCompat SameWire impossible
riNotCompat GAny impossible
riNotCompat AnyG impossible

rintNotCompat : Compatible Reset Interrupt -> Void
rintNotCompat SameWire impossible
rintNotCompat GAny impossible
rintNotCompat AnyG impossible

rcNotCompat : Compatible Reset Control -> Void
rcNotCompat SameWire impossible
rcNotCompat GAny impossible
rcNotCompat AnyG impossible

infoINotCompat : Compatible Info Interrupt -> Void
infoINotCompat SameWire impossible
infoINotCompat GAny impossible
infoINotCompat AnyG impossible

infoCNotCompat : Compatible Info Control -> Void
infoCNotCompat SameWire impossible
infoCNotCompat GAny impossible
infoCNotCompat AnyG impossible

interCNotCompat : Compatible Interrupt Control -> Void
interCNotCompat SameWire impossible
interCNotCompat GAny impossible
interCNotCompat AnyG impossible

namespace Compatibility
  namespace Wire
    public export
    data Error = TypesDiffer Wire Wire

export
compatible : (l,r : Wire) -> DecInfo Compatibility.Wire.Error (Compatible l r)
compatible a@Data      b@Data      = Yes SameWire
compatible a@Data      b@Address   = No (TypesDiffer a b) daNotCompat
compatible a@Data      b@Clock     = No (TypesDiffer a b) dcNotCompat
compatible a@Data      b@Reset     = No (TypesDiffer a b) drNotCompat
compatible a@Data      b@Info      = No (TypesDiffer a b) ddNotCompat
compatible a@Data      b@Interrupt = No (TypesDiffer a b) diNotCompat
compatible a@Data      b@Control   = No (TypesDiffer a b) dctrlNotCompat
compatible a@Data      b@General   = Yes AnyG
compatible a@Address   b@Data      = No (TypesDiffer a b) $ negCompatibleSym daNotCompat
compatible a@Address   b@Address   = Yes SameWire
compatible a@Address   b@Clock     = No (TypesDiffer a b) acNotCompat
compatible a@Address   b@Reset     = No (TypesDiffer a b) arNotCompat
compatible a@Address   b@Info      = No (TypesDiffer a b) aiNotCompat
compatible a@Address   b@Interrupt = No (TypesDiffer a b) aitNotCompat
compatible a@Address   b@Control   = No (TypesDiffer a b) actrlNotCompat
compatible a@Address   b@General   = Yes AnyG
compatible a@Clock     b@Data      = No (TypesDiffer a b) (negCompatibleSym dcNotCompat)
compatible a@Clock     b@Address   = No (TypesDiffer a b) (negCompatibleSym acNotCompat)
compatible a@Clock     b@Clock     = Yes SameWire
compatible a@Clock     b@Reset     = No (TypesDiffer a b) crNotCompat
compatible a@Clock     b@Info      = No (TypesDiffer a b) ciNotCompat
compatible a@Clock     b@Interrupt = No (TypesDiffer a b) cintNotCompat
compatible a@Clock     b@Control   = No (TypesDiffer a b) ccNotCompatc
compatible a@Clock     b@General   = Yes AnyG
compatible a@Reset     b@Data      = No (TypesDiffer a b) (negCompatibleSym drNotCompat)
compatible a@Reset     b@Address   = No (TypesDiffer a b) (negCompatibleSym arNotCompat)
compatible a@Reset     b@Clock     = No (TypesDiffer a b) (negCompatibleSym crNotCompat)
compatible a@Reset     b@Reset     = Yes SameWire
compatible a@Reset     b@Info      = No (TypesDiffer a b) riNotCompat
compatible a@Reset     b@Interrupt = No (TypesDiffer a b) rintNotCompat
compatible a@Reset     b@Control   = No (TypesDiffer a b) rcNotCompat
compatible a@Reset     b@General   = Yes AnyG
compatible a@Info      b@Data      = No (TypesDiffer a b) (negCompatibleSym ddNotCompat)
compatible a@Info      b@Address   = No (TypesDiffer a b) (negCompatibleSym aiNotCompat)
compatible a@Info      b@Clock     = No (TypesDiffer a b) (negCompatibleSym ciNotCompat)
compatible a@Info      b@Reset     = No (TypesDiffer a b) (negCompatibleSym riNotCompat)
compatible a@Info      b@Info      = Yes SameWire
compatible a@Info      b@Interrupt = No (TypesDiffer a b) infoINotCompat
compatible a@Info      b@Control   = No (TypesDiffer a b) infoCNotCompat
compatible a@Info      b@General   = Yes AnyG
compatible a@Interrupt b@Data      = No (TypesDiffer a b) (negCompatibleSym diNotCompat)
compatible a@Interrupt b@Address   = No (TypesDiffer a b) (negCompatibleSym aitNotCompat)
compatible a@Interrupt b@Clock     = No (TypesDiffer a b) (negCompatibleSym cintNotCompat)
compatible a@Interrupt b@Reset     = No (TypesDiffer a b) (negCompatibleSym rintNotCompat)
compatible a@Interrupt b@Info      = No (TypesDiffer a b) (negCompatibleSym infoINotCompat)
compatible a@Interrupt b@Interrupt = Yes SameWire
compatible a@Interrupt b@Control   = No (TypesDiffer a b) interCNotCompat
compatible a@Interrupt b@General   = Yes AnyG
compatible a@Control   b@Data      = No (TypesDiffer a b) (negCompatibleSym dctrlNotCompat)
compatible a@Control   b@Address   = No (TypesDiffer a b) (negCompatibleSym actrlNotCompat)
compatible a@Control   b@Clock     = No (TypesDiffer a b) (negCompatibleSym ccNotCompatc)
compatible a@Control   b@Reset     = No (TypesDiffer a b) (negCompatibleSym rcNotCompat)
compatible a@Control   b@Info      = No (TypesDiffer a b) (negCompatibleSym infoCNotCompat)
compatible a@Control   b@Interrupt = No (TypesDiffer a b) (negCompatibleSym interCNotCompat)

compatible Control Control = Yes SameWire
compatible Control General = Yes AnyG
compatible General r = Yes GAny

-- [ EOF ]


module datastore_exercises

import DataStore

testStore : DataStore (SString .+. (SString .+. SInt))
testStore =
  addToStore ("Mercury", "Mariner 10", 1974) $
  addToStore ("Venus", "Venera", 1961) $
  addToStore ("Uranus", "Voyager 2", 1986) $
  addToStore ("Pluto", "New Horizons", 2015) $
  empty

getValues : DataStore (SString .+. val_schema) -> List (SchemaType val_schema)
getValues store with (storeView store)
  getValues empty | SNil = []
  getValues (addToStore (_, value) store) | SAdd store' = value :: getValues store | store'


module Bautzen.ZoC

import Bautzen.GameUnit
import Bautzen.Pos

import Data.List.Extra

import Data.List
import Data.Nat
import Data.Vect

-- section 3
-- zones of control

public export
data ZoC : Type where
  InZoC : (side : Side) -> ZoC
  Free : ZoC

public export
Eq ZoC where
  Free == Free = True
  (InZoC s) == (InZoC s') = s == s'
  _ == _ = False

||| Test if given position for given `side` is in the ZoC of the unit.
public export
inZocOf : (pos : Pos) -> (side : Side) -> (GameUnit, Pos) -> Bool
inZocOf pos curSide (unit, location) with (curSide == side (nation unit))
  inZocOf pos curSide (unit, location) | False = pos `elem` neighbours location
  inZocOf pos curSide (unit, location) | True = False

||| Is the given `Pos`ition in an enemy ZoC?
||| This assumes the current `side` is playing and checking ZoCs
public export
inZoC : Side -> List (GameUnit, Pos) -> Pos -> ZoC
inZoC curSide units pos =
  case find' (inZocOf pos curSide) units of
    Nothing => Free
    (Just (unit, _)) => InZoC (side $ nation unit)

-- ZoC tests

-- inZoCTrue : inZocOf (Hex 3 3) Axis (Bautzen.GameUnit.p13_5dp, Hex 3 4) = True
-- inZoCTrue = Refl

-- inZoCTrue2 : inZocOf (Hex 4 3) Axis (Bautzen.GameUnit.p13_5dp, Hex 3 4) = False
-- inZoCTrue2 = Refl

-- inZoCFalsePolish : inZocOf (Hex 3 3) Allies (Bautzen.GameUnit.p13_5dp, Hex 3 4) = False
-- inZoCFalsePolish = Refl


module Control.Cont.Void

import Control.EffectAlgebra
import Control.HigherOrder

import Control.Monad.Free

public export
data VoidC1 : Type -> Type where

public export
VoidC : (Type -> Type) -> (Type -> Type)
VoidC = Lift VoidC1

public export
VoidE : (Type -> Type) -> (Type -> Type)
VoidE = Lift VoidC1

public export
Uninhabited (VoidC1 a) where
  uninhabited x impossible

public export
Functor VoidC1 where
  map f x impossible

public export
runVoidC : Free VoidC a -> a
runVoidC (Return x) = x
runVoidC (Op (MkLift x)) = absurd x

namespace Algebra
  public export
  [Void] (mon : Monad m) => Algebra VoidE m where
    alg ctx hdl (MkLift x) = absurd x

  %hint
  public export
  AlgebraVoid : (mon : Monad m) => Algebra VoidE m
  AlgebraVoid = Algebra.Void


module Control.Arrow

import Control.Category
import Data.Either
import Data.Morphisms

infixr 5 <++>
infixr 3 ***
infixr 3 &&&
infixr 2 +++
infixr 2 \|/

public export
interface Category arr => Arrow (0 arr : Type -> Type -> Type) where
  ||| Converts a function from input to output into a arrow computation.
  arrow  : (a -> b) -> arr a b
  ||| Converts an arrow from `a` to `b` into an arrow on pairs, that applies
  ||| its argument to the first component and leaves the second component
  ||| untouched, thus saving its value across a computation.
  first  : arr a b -> arr (a, c) (b, c)
  ||| Converts an arrow from `a` to `b` into an arrow on pairs, that applies
  ||| its argument to the second component and leaves the first component
  ||| untouched, thus saving its value across a computation.
  second : arr a b -> arr (c, a) (c, b)
  second f = arrow {arr = arr} swap >>> first f >>> arrow {arr = arr} swap
    where
    swap : (x, y) -> (y, x)
    swap (a, b) = (b, a)
  ||| A combinator which processes both components of a pair.
  (***)  : arr a b -> arr a' b' -> arr (a, a') (b, b')
  f *** g = first f >>> second g
  ||| A combinator which builds a pair from the results of two arrows.
  (&&&)  : arr a b -> arr a b' -> arr a (b, b')
  f &&& g = arrow dup >>> f *** g

public export
implementation Arrow Morphism where
  arrow  f            = Mor f
  first  (Mor f)      = Mor $ \(a, b) => (f a, b)
  second (Mor f)      = Mor $ \(a, b) => (a, f b)
  (Mor f) *** (Mor g) = Mor $ \(a, b) => (f a, g b)
  (Mor f) &&& (Mor g) = Mor $ \a => (f a, g a)

public export
implementation Monad m => Arrow (Kleislimorphism m) where
  arrow f = Kleisli (pure . f)
  first (Kleisli f) =  Kleisli $ \(a, b) => do x <- f a
                                               pure (x, b)

  second (Kleisli f) = Kleisli $ \(a, b) => do x <- f b
                                               pure (a, x)

  (Kleisli f) *** (Kleisli g) = Kleisli $ \(a, b) => do x <- f a
                                                        y <- g b
                                                        pure (x, y)

  (Kleisli f) &&& (Kleisli g) = Kleisli $ \a => do x <- f a
                                                   y <- g a
                                                   pure (x, y)

public export
interface Arrow arr => ArrowZero (0 arr : Type -> Type -> Type) where
  zeroArrow : arr a b

public export
interface ArrowZero arr => ArrowPlus (0 arr : Type -> Type -> Type) where
  (<++>) : arr a b -> arr a b -> arr a b

public export
interface Arrow arr => ArrowChoice (0 arr : Type -> Type -> Type) where
  left  : arr a b -> arr (Either a c) (Either b c)

  right : arr a b -> arr (Either c a) (Either c b)
  right f = arrow mirror >>> left f >>> arrow mirror

  (+++) : arr a b -> arr c d -> arr (Either a c) (Either b d)
  f +++ g = left f >>> right g

  (\|/) : arr a b -> arr c b -> arr (Either a c) b
  f \|/ g = f +++ g >>> arrow fromEither
    where
    fromEither : Either b b -> b
    fromEither (Left b) = b
    fromEither (Right b) = b

public export
implementation Monad m => ArrowChoice (Kleislimorphism m) where
  left f                      = f          +++ (arrow id)
  right f                     = (arrow id) +++ f
  f           +++ g           = (f >>> (arrow Left)) \|/ (g >>> (arrow Right))
  (Kleisli f) \|/ (Kleisli g) = Kleisli (either f g)

public export
interface Arrow arr => ArrowApply (0 arr : Type -> Type -> Type) where
  app : arr (arr a b, a) b

public export
implementation Monad m => ArrowApply (Kleislimorphism m) where
  app = Kleisli $ \(Kleisli f, x) => f x

public export
data ArrowMonad : (Type -> Type -> Type) -> Type -> Type where
  MkArrowMonad : (runArrowMonad : arr (the Type ()) a) -> ArrowMonad arr a

public export
runArrowMonad : ArrowMonad arr a -> arr (the Type ()) a
runArrowMonad (MkArrowMonad a) = a

public export
implementation Arrow a => Functor (ArrowMonad a) where
  map f (MkArrowMonad m) = MkArrowMonad $ m >>> arrow f

public export
implementation Arrow a => Applicative (ArrowMonad a) where
  pure x = MkArrowMonad $ arrow $ \_ => x
  (MkArrowMonad f) <*> (MkArrowMonad x) = MkArrowMonad $ f &&& x >>> arrow (uncurry id)

public export
implementation ArrowApply a => Monad (ArrowMonad a) where
  (MkArrowMonad m) >>= f =
    MkArrowMonad $ m >>> (arrow $ \x => (runArrowMonad (f x), ())) >>> app

public export
interface Arrow arr => ArrowLoop (0 arr : Type -> Type -> Type) where
  loop : arr (Pair a c) (Pair b c) -> arr a b

||| Applying a binary operator to the results of two arrow computations.
public export
liftA2 : Arrow arr => (a -> b -> c) -> arr d a -> arr d b -> arr d c
liftA2 op f g = (f &&& g) >>> arrow (\(a, b) => a `op` b)


-- This shows python style string multiplication
-- 'xy_' * 5 = 'xy_xy_xy_xy_xy_'
--
module Main
import Data.Strings

myStrMult : String -> Nat -> String
myStrMult str 0 = ""
myStrMult str (S k) = str ++ myStrMult str k

main : IO ()
main = do printLn $ myStrMult "xy_" 5
          putStr "Enter a String: "
          str <- getLine
          putStr "Enter a positive Integer: "
          num <- getLine
          printLn $ myStrMult str (stringToNatOrZ num)


module Main

import Average

showAverage : String -> String
showAverage str = "The average word length is " ++
                  show (average str) ++ "\n"

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


module Crypto.Hash.OID

import Crypto.Hash.Interfaces
import Crypto.Hash
import Data.Vect

{-
  For the nine hash functions mentioned in Appendix B.1, the DER
  encoding T of the DigestInfo value is equal to the following:

  MD2:     (0x)30 20 30 0c 06 08 2a 86 48 86 f7 0d 02 02 05 00 04
               10 || H.
  MD5:     (0x)30 20 30 0c 06 08 2a 86 48 86 f7 0d 02 05 05 00 04
               10 || H.
  SHA-1:   (0x)30 21 30 09 06 05 2b 0e 03 02 1a 05 00 04 14 || H.
  SHA-224:  (0x)30 2d 30 0d 06 09 60 86 48 01 65 03 04 02 04
               05 00 04 1c || H.
  SHA-256: (0x)30 31 30 0d 06 09 60 86 48 01 65 03 04 02 01 05 00
               04 20 || H.
  SHA-384: (0x)30 41 30 0d 06 09 60 86 48 01 65 03 04 02 02 05 00
               04 30 || H.
  SHA-512: (0x)30 51 30 0d 06 09 60 86 48 01 65 03 04 02 03 05 00
               04 40 || H.
  SHA-512/224:  (0x)30 2d 30 0d 06 09 60 86 48 01 65 03 04 02 05
                    05 00 04 1c || H.
  SHA-512/256:  (0x)30 31 30 0d 06 09 60 86 48 01 65 03 04 02 06
                    05 00 04 20 || H.
-}

public export
interface Hash algo => RegisteredHash algo where
  header_n_byte : Nat
  header : Vect header_n_byte Bits8

public export
der_digest_n_byte : {algo : _} -> RegisteredHash algo => Nat
der_digest_n_byte = header_n_byte {algo} + digest_nbyte {algo}

export
hashWithHeader : {algo : _} -> RegisteredHash algo => List Bits8 -> Vect (der_digest_n_byte {algo}) Bits8
hashWithHeader plaintext = header {algo} ++ hash algo plaintext

public export
RegisteredHash Sha1 where
  header_n_byte = 15
  header = [ 0x30, 0x21, 0x30, 0x09, 0x06, 0x05, 0x2b, 0x0e, 0x03, 0x02, 0x1a, 0x05, 0x00, 0x04, 0x14 ]

public export
RegisteredHash Sha256 where
  header_n_byte = 19
  header = [ 0x30, 0x31, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x01, 0x05, 0x00, 0x04, 0x20 ]

public export
RegisteredHash Sha384 where
  header_n_byte = 19
  header = [ 0x30, 0x41, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x02, 0x05, 0x00, 0x04, 0x30 ]

public export
RegisteredHash Sha512 where
  header_n_byte = 19
  header = [ 0x30, 0x51, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x03, 0x05, 0x00, 0x04, 0x40 ]


module Data.Date

import Data.List1
import Data.String

%default total

public export
record Date where
  constructor MkDate
  year, month, day : Nat

export
Show Date where
  show (MkDate year month day) = "\{show year}-\{pad month}-\{pad day}"
    where
      pad : Nat -> String
      pad k = if k < 10
                 then "0\{show k}"
                 else show k

export
Eq Date where
  (MkDate year month day) == (MkDate year' month' day') =
    year == year' && month == month' && day == day'

export
Ord Date where
  compare (MkDate year month day) (MkDate year' month' day') =
    compare [year, month, day] [year', month', day']

parsePositiveReversed : List Char -> Maybe Nat
parsePositiveReversed [] = Just 0
parsePositiveReversed (x :: xs) = [ n + 10 * !(parsePositiveReversed xs) | n <- parseNat x ]
  where
    parseNat : Char -> Maybe Nat
    parseNat '0' = Just 0
    parseNat '1' = Just 1
    parseNat '2' = Just 2
    parseNat '3' = Just 3
    parseNat '4' = Just 4
    parseNat '5' = Just 5
    parseNat '6' = Just 6
    parseNat '7' = Just 7
    parseNat '8' = Just 8
    parseNat '9' = Just 9
    parseNat _   = Nothing

export
parseDateString : String -> Maybe Date
parseDateString = guardSuccess . foldl go (Start ** ()) . unpack
  where
    data PrimaryPart = Year | Month

    data Part = Start
              | ||| Primary Part
                P PrimaryPart
              | ||| Separator (dash) following given primary part.
                S PrimaryPart
              | Day
              | Fail

    Partial : Part -> Type
    Partial Start     = ()
    Partial (P Year)  = List Char             -- partial year
    Partial (S Year)  = Nat                   -- full year
    Partial (P Month) = (Nat, List Char)      -- partial month
    Partial (S Month) = (Nat, Nat)            -- full month
    Partial Day       = (Nat, Nat, List Char) -- partial day
    Partial Fail      = ()

    -- if we are on day, parse it as a number and construct a
    -- Date or fail.
    guardSuccess : (part ** Partial part) -> Maybe Date
    guardSuccess (Day ** (y, m, cs)) = MkDate y m <$> parsePositiveReversed cs
    guardSuccess _ = Nothing

    go : (part ** Partial part) -> Char -> (part ** Partial part)
    go (Fail ** ()) c = (Fail ** ())

    -- kick things off with a digit
    go (Start ** ()) c = if isDigit c then (P Year ** [c]) else (Fail ** ())

    -- collect until you find a dash, then reverse and parse as number
    go ((P Year) ** cs) '-' = case parsePositiveReversed cs of
                                Nothing  => (Fail ** ())
                                (Just y) => (S Year ** y)
    go ((P Year) ** cs) c = (P Year ** c :: cs)

    -- kick things off with a digit
    go ((S Year) ** snd) c = if isDigit c then (P Month ** (snd, [c])) else (Fail ** ())

    -- collect until you find a dash, then reverse and parse as number
    go ((P Month) ** (y, cs)) '-' = case parsePositiveReversed cs of
                                         Nothing  => (Fail ** ())
                                         (Just m) => (S Month ** (y, m))
    go ((P Month) ** (y, cs)) c = (P Month ** (y, c :: cs))

    -- kick things off with a digit
    go ((S Month) ** (y, m)) c = if isDigit c then (Day ** (y, m, [c])) else (Fail ** ())

    -- collect until you are done
    go (Day ** (y, m, cs)) c = (Day ** (y, m, c :: cs))

export
parseDateTimeString : String -> Maybe Date
parseDateTimeString = parseDateString . head . split (== 'T')