||| Implementation of ordering relations for the primitive type `Int`
||| This is full of tricks as `Int` is a primitive type that can only
||| be interacted with using either literals or built-in functions.
||| The exported interface should however be safe.
module Data.Int.Order

import Data.Order

%default total

------------------------------------------------------------------------
-- Introduction

-- The type `Int` is a primitive type in Idris. The only handle we have on
-- it is provided by built-in functions. This is what we are going to use
-- to define relations on Int values. For instance, we will declare that
-- `a` is strictly less than `b` whenever `a < b` is provably equal to `True`.

-- These built-in functions only reduce on literals. This means we will not
-- be able to rely on their computational behaviour to prove statements in
-- open contexts.

-- For instance, no amount of pattern-matching will help us prove:
-- LT_not_EQ : LT a b -> Not (EQ a b)

-- Our solution in this file is to use unsafe primitives to manufacture such
-- proofs. This means we are going to essentially postulate some *conditional*
-- results. We do not want such conditional results to reduce to canonical
-- forms too eagerly.

-- Indeed the statement `GT 0 1 -> EQ 0 1` should be provable because 0 is not
-- greater than 1. But its proof should not reduce to a constant function
-- returning the value `Refl` because it is not true that `0` and `1` can be
-- unified. If the proof were to behave this way, we could, in an absurd context,
-- coerce values from any type to any other and cause segmentation faults.

-- Our solution is to be extremely wary of proofs that are passed to us
-- and to only consider returning a magically-crafted output if we have
-- managed to observe that the input is itself in canonical form i.e. to
-- have evaluation stuck on open terms.

-- This is the purpose of the `strictX : X -> Lazy c -> c` functions defined in
-- this file. They all will be waiting until their first argument is in canonical
-- form before returning their second.

------------------------------------------------------------------------
-- Utility functions for equality

||| Pattern-match on an equality proof so that the second argument to
||| strictRefl is only returned once the first is canonical.
export
strictRefl : a === b -> Lazy c -> c
strictRefl Refl p = p

||| Do NOT re-export
unsafeRefl : {0 a, b : t} -> a === b
unsafeRefl = believe_me (the (a === a) Refl)

------------------------------------------------------------------------
-- LT

namespace LT

  ||| `LT a b` is a proof that `a` is less than `b` which is to say that
  ||| the function call `a < b` returns `True`.
  |||
  ||| NB: we do not re-export the constructor so that users cannot force
  ||| our magic functions to blow up in absurd contexts by bypassing the
  ||| safety measures introduced by the `strictX` functions.
  ||| We do provide functions corresponding to the wrapping and unwrapping
  ||| of `LT` but, crucially, they do not let people force `LT` proofs to
  ||| be in canonical form.
  export
  data LT : Int -> Int -> Type where
    MkLT : (a < b) === True -> LT a b

  ||| We may prove `LT a b` by using a proof that `a < b` returns `True`.
  export
  mkLT : (a < b) === True -> LT a b
  mkLT = MkLT

  ||| From a proof that `LT a b`, we may concluded that `a < b` returns `True`.
  export
  runLT : LT a b -> (a < b) === True
  runLT (MkLT eq) = eq

  ||| Do not trust arbitrary `LT` proofs when manufacturing magic ones:
  ||| be strict!
  export
  strictLT : LT a b -> Lazy c -> c
  strictLT (MkLT p) c = strictRefl p c

  ||| LT is decidable, by virtue of being the reflection of a boolean function
  export
  decide : (a, b : Int) -> Dec (LT a b)
  decide a b with (the (test : Bool ** (a < b) === test) (a < b ** Refl))
    decide a b | (True ** p) = Yes (MkLT p)
    decide a b | (False ** p) = No (\ (MkLT q) => absurd (trans (sym p) q))

  ||| LT is a transitive relation. This cannot be proven so we use a magic trick.
  export
  trans : LT a b -> LT b c -> LT a (the Int c)
  trans p q = strictLT p $ strictLT q $ MkLT unsafeRefl

  ||| LT is an irreflexive relation.
  ||| The crash will never happen because the `LT a a` argument will never reduce
  ||| to a canonical form (unless the built-in function (<) is buggy).
  export
  irrefl : Not (LT a a)
  irrefl p = strictLT p
           $ assert_total $ idris_crash "IMPOSSIBLE: LT is irreflexive"

------------------------------------------------------------------------
-- GT

||| GT is defined in terms of LT to avoid code duplication
public export
GT : Int -> Int -> Type
GT = flip LT

export
LT_not_GT : LT a b -> Not (GT a b)
LT_not_GT p q = irrefl (trans p q)

export
GT_not_LT : GT a b -> Not (LT a b)
GT_not_LT = flip LT_not_GT

------------------------------------------------------------------------
-- EQ

namespace EQ

  ||| `EQ a b` is a proof that `a` is equal to `b` which is to say that
  ||| the function call `a == b` returns `True`.
  |||
  ||| NB: we do not re-export the constructor so that users cannot force
  ||| our magic functions to blow up in absurd contexts by bypassing the
  ||| safety measures introduced by the `strictX` functions.
  ||| We do provide functions corresponding to the wrapping and unwrapping
  ||| of `EQ` but, crucially, they do not let people force `EQ` proofs to
  ||| be in canonical form.
  export
  data EQ : Int -> Int -> Type where
    MkEQ : (a == b) === True -> EQ a b

  ||| We may prove `EQ a b` by using a proof that `a == b` returns `True`.
  export
  mkEQ : (a == b) === True -> EQ a b
  mkEQ = MkEQ

  ||| From a proof that `EQ a b`, we may concluded that `a == b` returns `True`.
  export
  runEQ : EQ a b -> (a == b) === True
  runEQ (MkEQ eq) = eq

  ||| Do not trust arbitrary `EQ` proofs when manufacturing magic ones:
  ||| be strict!
  export
  strictEQ : EQ a b -> Lazy c -> c
  strictEQ (MkEQ p) c = strictRefl p c

  ||| EQ is decidable, by virtue of being the reflection of a boolean function
  export
  decide : (a, b : Int) -> Dec (EQ a b)
  decide a b with (the (test : Bool ** (a == b) === test) (a == b ** Refl))
    decide a b | (True  ** p) = Yes (MkEQ p)
    decide a b | (False ** p) = No (\ (MkEQ q) => absurd (trans (sym p) q))

  ||| EQ is a reflexive relation
  export
  refl : EQ a a
  refl = MkEQ unsafeRefl

  ||| EQ is substitutive
  export
  elimEQ : (0 p : Int -> Type) -> EQ a b -> p a -> p b
  elimEQ _ p v = strictEQ p $ believe_me v

  ||| EQ implies propositional equality
  export
  reflect : EQ a b -> a === b
  reflect p = elimEQ (\ b => a === b) p Refl

  ||| EQ is a symmetric relation
  export
  sym : EQ a b -> EQ b a
  sym p = elimEQ (\ b => EQ b a) p refl

  ||| EQ is a transitive relation
  export
  trans : EQ a b -> EQ b c -> EQ a c
  trans p q = elimEQ (\ b => EQ b c) (sym p) q

export
trans_LT_EQ : LT a b -> EQ b c -> LT a c
trans_LT_EQ p q = elimEQ (LT a) q p

export
trans_EQ_LT : EQ a b -> LT b c -> LT a c
trans_EQ_LT p q = elimEQ (\ b => LT b c) (sym p) q

export
LT_not_EQ : LT a b -> Not (EQ a b)
LT_not_EQ p q = irrefl (trans_LT_EQ p (sym q))

export
EQ_not_LT : EQ a b -> Not (LT a b)
EQ_not_LT = flip LT_not_EQ

export
EQ_not_GT : EQ a b -> Not (GT a b)
EQ_not_GT = EQ_not_LT . sym

export
GT_not_EQ : GT a b -> Not (EQ a b)
GT_not_EQ = flip EQ_not_GT

------------------------------------------------------------------------
-- LTE

namespace LTE

  ||| `LTE a b` is a proof that `a` is less or equal to `b` which is to say that
  ||| the function call `a < b` or `a == b` returns `True`.
  |||
  ||| NB: we do not re-export the constructor so that users cannot force
  ||| our magic functions to blow up in absurd contexts by bypassing the
  ||| safety measures introduced by the `strictX` functions.
  export
  data LTE : Int -> Int -> Type where
    MkLT : (a < b)  === True -> LTE a b
    MkEQ : (a == b) === True -> LTE a b

  ||| Unwrap an LTE proof to get either an LT or an EQ one
  export
  runLTE : LTE a b -> Either (LT a b) (EQ a b)
  runLTE (MkLT p) = Left (mkLT p)
  runLTE (MkEQ p) = Right (mkEQ p)

  ||| Do not trust arbitrary `LTE` proofs when manufacturing magic ones:
  ||| be strict!
  export
  strictLTE : LTE a b -> Lazy c -> c
  strictLTE (MkLT p) q = strictRefl p q
  strictLTE (MkEQ p) q = strictRefl p q

  ||| LTE is decidable by virture of both LT and EQ being decidable
  export
  decide : (a, b : Int) -> Dec (LTE a b)
  decide a b with (LT.decide a b)
    decide a b | Yes p = Yes (MkLT (runLT p))
    decide a b | No notLT with (EQ.decide a b)
      decide a b | No notLT | Yes p = Yes (MkEQ (runEQ p))
      decide a b | No notLT | No notEQ = No $ \ case
        MkLT p => notLT (mkLT p)
        MkEQ p => notEQ (mkEQ p)

  ||| LTE is a reflexive relation
  export
  refl : LTE a a
  refl = MkEQ unsafeRefl

  export
  trans_LT_LTE : LT a b -> LTE b c -> LT a c
  trans_LT_LTE p (MkLT q) = trans p (mkLT q)
  trans_LT_LTE p (MkEQ q) = trans_LT_EQ p (mkEQ q)

  export
  trans_LTE_LT : LTE a b -> LT b c -> LT a c
  trans_LTE_LT (MkLT p) q = trans (mkLT p) q
  trans_LTE_LT (MkEQ p) q = trans_EQ_LT (mkEQ p) q

  export
  inject_LT_LTE : LT a b -> LTE a b
  inject_LT_LTE = MkLT . runLT

  export
  inject_EQ_LTE : EQ a b -> LTE a b
  inject_EQ_LTE p = MkEQ (runEQ p)

  ||| LTE is a transitive relation
  export
  trans : LTE a b -> LTE b c -> LTE a c
  trans (MkLT p) q = inject_LT_LTE (trans_LT_LTE (mkLT p) q)
  trans p (MkLT q) = inject_LT_LTE (trans_LTE_LT p (mkLT q))
  trans (MkEQ p) (MkEQ q) = inject_EQ_LTE (trans (mkEQ p) (mkEQ q))

  ||| LTE is an antisymmetric relation
  export
  antisym : LTE a b -> LTE b a -> EQ a b
  antisym (MkEQ p) _ = mkEQ p
  antisym _ (MkEQ p) = EQ.sym (mkEQ p)
  antisym (MkLT p) (MkLT q) = absurd $ LT.irrefl (LT.trans (mkLT p) (mkLT q))

------------------------------------------------------------------------
-- GTE

||| GTE is defined in terms of LTE to avoid code duplication
public export
GTE : Int -> Int -> Type
GTE = flip LTE

------------------------------------------------------------------------
-- Trichotomy and other decidability results

||| Any pair of Ints is related either via LT, EQ, or GT
export
trichotomous : (a, b : Int) -> Trichotomous LT EQ GT a b
trichotomous a b with (LTE.decide a b)
  trichotomous a b | Yes lte = case runLTE lte of
    Left lt  => MkLT lt (LT_not_EQ lt) (LT_not_GT lt)
    Right eq => MkEQ (EQ_not_LT eq) eq (EQ_not_GT eq)
  trichotomous a b | No notLTE = let gt = mkLT unsafeRefl in MkGT (GT_not_LT gt) (GT_not_EQ gt) gt

||| Any pair of Ints is related either via LT or GTE
export
decide_LT_GTE : (a, b : Int) -> Either (LT a b) (GTE a b)
decide_LT_GTE a b with (trichotomous a b)
  decide_LT_GTE a b | MkLT lt _ _ = Left lt
  decide_LT_GTE a b | MkEQ _ eq _ = Right (inject_EQ_LTE (sym eq))
  decide_LT_GTE a b | MkGT _ _ gt = Right (inject_LT_LTE gt)

||| Any pair of Ints is related either via LTE or GT
export
decide_LTE_GT : (a, b : Int) -> Either (LTE a b) (GT a b)
decide_LTE_GT a b with (trichotomous a b)
  decide_LTE_GT a b | MkLT lt _ _ = Left (inject_LT_LTE lt)
  decide_LTE_GT a b | MkEQ _ eq _ = Left (inject_EQ_LTE eq)
  decide_LTE_GT a b | MkGT _ _ gt = Right gt

------------------------------------------------------------------------
-- Some properties

||| Adding one to a strictly smaller Int, yields a smaller Int
export
suc_LT_LTE : {a, b : Int} -> LT a b -> LTE (a + 1) b
suc_LT_LTE p with (the (test : Bool ** (a + 1 == b) === test) (a + 1 == b ** Refl))
  suc_LT_LTE p | (True  ** q) = inject_EQ_LTE $ mkEQ q
  suc_LT_LTE p | (False ** q) = strictLT p $ inject_LT_LTE $ mkLT unsafeRefl

||| Subtracting one to a strictly larger Int, yields a larger Int
export
pred_LT_LTE : {a, b : Int} -> LT a b -> LTE a (b - 1)
pred_LT_LTE p with (the (test : Bool ** (a == b - 1) === test) (a == b - 1 ** Refl))
  pred_LT_LTE p | (True  ** q) = inject_EQ_LTE $ mkEQ q
  pred_LT_LTE p | (False ** q) = strictLT p $ inject_LT_LTE $ mkLT unsafeRefl

||| Adding one to an Int yields a strictly larger one,
||| provided there is no overflow
export
sucBounded : LT a b -> LT a (a + 1)
sucBounded p = strictLT p $ mkLT unsafeRefl


module Circuits.Common

import System

import Decidable.Equality

import Data.Nat
import Toolkit.Data.Whole

%default total

export
processArgs : List String -> IO String
processArgs [exe,fname] = pure fname
processArgs _
  = do putStrLn "Exactly one file at a time."
       exitFailure

public export
data DType = LOGIC | BVECT Whole DType

public export
size : DType -> Nat
size LOGIC = (S Z)
size (BVECT (W (S n) ItIsSucc) type)
  = mult (S n) (size type)

Uninhabited (LOGIC = BVECT n k) where
  uninhabited Refl impossible

export
DecEq DType where
  decEq LOGIC LOGIC = Yes Refl
  decEq LOGIC (BVECT k x) = No absurd

  decEq (BVECT k x) LOGIC = No (negEqSym absurd)
  decEq (BVECT k x) (BVECT j y) with (decEq k j)
    decEq (BVECT k x) (BVECT k y) | (Yes Refl) with (decEq x y)
      decEq (BVECT k x) (BVECT k x) | (Yes Refl) | (Yes Refl)
        = Yes Refl
      decEq (BVECT k x) (BVECT k y) | (Yes Refl) | (No contra)
        = No (\Refl => contra Refl)

    decEq (BVECT k x) (BVECT j y) | (No contra)
      = No (\Refl => contra Refl)

public export
data Usage = USED | FREE

Uninhabited (USED = FREE) where
  uninhabited Refl impossible

export
DecEq Usage where
  decEq USED USED = Yes Refl
  decEq USED FREE = No absurd
  decEq FREE USED = No (negEqSym absurd)
  decEq FREE FREE = Yes Refl

-- [ EOF ]


module Main

f : Int -> Bool
f n = if n `mod` 2 == 0 then True else False

factx : Int -> Lazy Int
factx 0 = 0
factx n = n + factx (n - 1) + sx n
        where
            sx 1 = 3
            sx n = 1 + sx (n - 1)

main : IO ()
main = do
    let t = sum [0,50,50]
    -- let t = 100
    putStrLn $ show $ t
    let abc = factx $ t
    putStrLn $ show $ Force abc
    -- putStrLn $ show $ abc
    putStrLn $ show $ f abc


module Toolkit.Data.List.Occurs.Error

%default total

namespace Occurs
  public export
  record Error where
    constructor MkError
    expected : Nat
    found    : Nat

-- [ EOF ]


module Mb

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

%language ElabReflection

export
maybeInfo : TypeInfo
maybeInfo = getInfo "Maybe"

data T : Type -> Type where
  TU : T Unit
  TI : T Int
  Ta : T a

tParamInfo : ParamTypeInfo
--tParamInfo = getParamInfo "T"

data P : Nat -> Type where
  PZ : P Z
  PS : (x : Nat) -> P (S x)
  P3 : (y : Nat) -> P (S y)

data Q : Nat -> Type where
  QZ : Q Z
  QS : (x : Nat) -> Q (S x)
  Q3 : (xs : List Nat) -> Q (S $ length xs)

data R : Nat -> Type where
  RZ  : R Z
  RS  : (x : Nat) -> R (S x)
  RSS : (y : Nat) -> R (S (S y))

pParamInfo : ParamTypeInfo
--pParamInfo = getParamInfo "P"

qParamInfo : ParamTypeInfo
--qParamInfo = getParamInfo "Q"

rParamInfo : ParamTypeInfo
--rParamInfo = getParamInfo "R"


-- --------------------------------------------------------------- [ Day10.idr ]
-- Module      : Data.Advent.Day10
-- Description : My solution to the Day 10 puzzle of the 2016 Advent of Code.
-- Copyright   : Copyright (c) 2016, Eric Bailey
-- License     : MIT
-- Link        : https://adventofcode.com/2016/day/2
-- --------------------------------------------------------------------- [ EOH ]
||| Day 10: Balance Bots
module Data.Advent.Day10

import Data.Advent.Day

import public Data.SortedMap

import Effects
import Effect.State

%default total

-- -------------------------------------------------------------- [ Data Types ]

%access public export

Chip : Type
Chip = Nat

OutBin : Type
OutBin = Nat

BotID : Type
BotID = Nat

data Give = ToBot BotID
          | ToOutBin OutBin

data Instruction = Bot BotID Give Give
                 | GoesTo Chip BotID

-- ----------------------------------------------------------------- [ Parsers ]

%default partial

%access export

nat : Parser Nat
nat = fromIntegerNat <$> integer

toBot : Parser Give
toBot = ToBot <$> (string "bot " *> nat) <?> "bot n"

toOutBin : Parser Give
toOutBin = ToOutBin <$> (string "output " *> nat) <?> "output n"

to : Parser Give
to = toBot <|> toOutBin <?> "{bot,output} n"

value : Parser Instruction
value = [| GoesTo (string "value " *> nat) (string " goes to bot " *> nat) |]

bot : Parser Instruction
bot = [| Bot (string "bot " *> nat)
             (string " gives low to " *> to)
             (string " and high to " *> to) |]

instruction : Parser Instruction
instruction = bot <|> value

-- ------------------------------------------------------------------- [ State ]

%default total

BotResponsibilities : Type
BotResponsibilities = SortedMap BotID (List Chip)

implementation Default BotResponsibilities where default = empty

BotState : Type -> Type
BotState ty = Eff ty [STATE BotResponsibilities]

-- ------------------------------------------------------------------- [ Logic ]

getChips : BotID -> BotState (List Chip)
getChips b = fromMaybe [] . lookup b <$> get

consChip : BotID -> Chip -> BotState ()
consChip b c = update (insert b (c :: !(getChips b)))

giveChip : Give -> Chip -> BotState (List (OutBin, Chip))
giveChip (ToBot b) c    = consChip b c *> pure []
giveChip (ToOutBin o) c = pure [(o, c)]

%default partial

zoom : List Instruction -> BotState (List (OutBin, Chip))
zoom []                    = pure []
zoom (i@(GoesTo c b)::is)  = consChip b c *> zoom is
zoom (i@(Bot b lo hi)::is) =
    do [c1,c2] <- sort <$> getChips b
         | _ => zoom (is ++ [i])
       pure $ !(giveChip lo c1) ++ !(giveChip hi c2) ++ !(zoom is)

-- ----------------------------------------------------------------- [ Example ]

example : BotState (List (OutBin, Chip))
example = zoom [
            GoesTo 5 2,
            Bot 2 (ToBot 1) (ToBot 0),
            GoesTo 3 1,
            Bot 1 (ToOutBin 1) (ToBot 0),
            Bot 0 (ToOutBin 2) (ToOutBin 0),
            GoesTo 2 2
          ]

runExample : List (OutBin, Chip)
runExample = runPure example

-- ---------------------------------------------------------------- [ Part One ]

partOne : List Instruction -> Maybe BotID
partOne is = runPure $ zoom is *> go <$> get
  where
    go : BotResponsibilities -> Maybe BotID
    go st = fst <$> find (\(_,cs) => sort cs == [17,61]) (toList st)

-- ---------------------------------------------------------------- [ Part Two ]

partTwo : List Instruction -> Nat
partTwo is = foldl go 1 (runPure (zoom is))
  where
    go : Nat -> (OutBin, Chip) -> Nat
    go acc (o,c) = if List.elem o [0,1,2] then c * acc else acc

-- -------------------------------------------------------------------- [ Main ]

namespace Main

    main : IO ()
    main = runDay $ MkDay 10 (some (instruction <* newline))
                    (pure . show . partOne)
                    (pure . show . partTwo)

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


module Core.Primitives

import Core.Core
import Core.Context
import Core.TT
import Core.Value
import Utils.String

import Data.Vect

%default covering

public export
record Prim where
  constructor MkPrim
  {arity : Nat}
  fn : PrimFn arity
  type : ClosedTerm
  totality : Totality

binOp : (Constant -> Constant -> Maybe Constant) ->
        {vars : _} -> Vect 2 (NF vars) -> Maybe (NF vars)
binOp fn [NPrimVal fc x, NPrimVal _ y]
    = map (NPrimVal fc) (fn x y)
binOp _ _ = Nothing

unaryOp : (Constant -> Maybe Constant) ->
          {vars : _} -> Vect 1 (NF vars) -> Maybe (NF vars)
unaryOp fn [NPrimVal fc x]
    = map (NPrimVal fc) (fn x)
unaryOp _ _ = Nothing

castString : Vect 1 (NF vars) -> Maybe (NF vars)
castString [NPrimVal fc (I i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (BI i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (B8 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (B16 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (B32 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (B64 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (Ch i)] = Just (NPrimVal fc (Str (stripQuotes (show i))))
castString [NPrimVal fc (Db i)] = Just (NPrimVal fc (Str (show i)))
castString _ = Nothing

castInteger : Vect 1 (NF vars) -> Maybe (NF vars)
castInteger [NPrimVal fc (I i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (B8 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (B16 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (B32 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (B64 i)] = Just (NPrimVal fc (BI i))
castInteger [NPrimVal fc (Ch i)] = Just (NPrimVal fc (BI (cast (cast {to=Int} i))))
castInteger [NPrimVal fc (Db i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (Str i)] = Just (NPrimVal fc (BI (cast i)))
castInteger _ = Nothing

castInt : Vect 1 (NF vars) -> Maybe (NF vars)
castInt [NPrimVal fc (BI i)] = Just (NPrimVal fc (I (fromInteger i)))
castInt [NPrimVal fc (B8 i)] = Just (NPrimVal fc (I i))
castInt [NPrimVal fc (B16 i)] = Just (NPrimVal fc (I i))
castInt [NPrimVal fc (B32 i)] = Just (NPrimVal fc (I i))
castInt [NPrimVal fc (B64 i)] = Just (NPrimVal fc (I (fromInteger i)))
castInt [NPrimVal fc (Db i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (Ch i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (Str i)] = Just (NPrimVal fc (I (cast i)))
castInt _ = Nothing

b8max : Int
b8max = 0x100

b16max : Int
b16max = 0x10000

b32max : Int
b32max = 0x100000000

b64max : Integer
b64max = 18446744073709551616 -- 0x10000000000000000

bitCastWrap : (i : Integer) -> (max : Integer) -> Integer
bitCastWrap i max
    = if i >= 0 -- oops, we don't have `rem` yet!
        then i `mod` max
        else max + i `mod` max

constantIntegerValue : Constant -> Maybe Integer
constantIntegerValue (I i)   = Just $ cast i
constantIntegerValue (BI i)  = Just i
constantIntegerValue (B8 i)  = Just $ cast i
constantIntegerValue (B16 i) = Just $ cast i
constantIntegerValue (B32 i) = Just $ cast i
constantIntegerValue (B64 i) = Just i
constantIntegerValue _       = Nothing

castBits8 : Vect 1 (NF vars) -> Maybe (NF vars)
castBits8 [NPrimVal fc constant] = do
    value <- constantIntegerValue constant
    let wrapped = bitCastWrap value (cast b8max)
    pure (NPrimVal fc (B8 (cast wrapped)))
castBits8 _ = Nothing

castBits16 : Vect 1 (NF vars) -> Maybe (NF vars)
castBits16 [NPrimVal fc constant] = do
    value <- constantIntegerValue constant
    let wrapped = bitCastWrap value (cast b16max)
    pure (NPrimVal fc (B16 (cast wrapped)))
castBits16 _ = Nothing

castBits32 : Vect 1 (NF vars) -> Maybe (NF vars)
castBits32 [NPrimVal fc constant] = do
    value <- constantIntegerValue constant
    let wrapped = bitCastWrap value (cast b32max)
    pure (NPrimVal fc (B32 (cast wrapped)))
castBits32 _ = Nothing

castBits64 : Vect 1 (NF vars) -> Maybe (NF vars)
castBits64 [NPrimVal fc constant] = do
    value <- constantIntegerValue constant
    let wrapped = bitCastWrap value b64max
    pure (NPrimVal fc (B64 wrapped))
castBits64 _ = Nothing

castDouble : Vect 1 (NF vars) -> Maybe (NF vars)
castDouble [NPrimVal fc (I i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (BI i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (Str i)] = Just (NPrimVal fc (Db (cast i)))
castDouble _ = Nothing

castChar : Vect 1 (NF vars) -> Maybe (NF vars)
castChar [NPrimVal fc (I i)] = Just (NPrimVal fc (Ch (cast i)))
castChar _ = Nothing

strLength : Vect 1 (NF vars) -> Maybe (NF vars)
strLength [NPrimVal fc (Str s)] = Just (NPrimVal fc (I (cast (length s))))
strLength _ = Nothing

strHead : Vect 1 (NF vars) -> Maybe (NF vars)
strHead [NPrimVal fc (Str "")] = Nothing
strHead [NPrimVal fc (Str str)]
    = Just (NPrimVal fc (Ch (assert_total (prim__strHead str))))
strHead _ = Nothing

strTail : Vect 1 (NF vars) -> Maybe (NF vars)
strTail [NPrimVal fc (Str "")] = Nothing
strTail [NPrimVal fc (Str str)]
    = Just (NPrimVal fc (Str (assert_total (prim__strTail str))))
strTail _ = Nothing

strIndex : Vect 2 (NF vars) -> Maybe (NF vars)
strIndex [NPrimVal fc (Str str), NPrimVal _ (I i)]
    = if i >= 0 && integerToNat (cast i) < length str
         then Just (NPrimVal fc (Ch (assert_total (prim__strIndex str i))))
         else Nothing
strIndex _ = Nothing

strCons : Vect 2 (NF vars) -> Maybe (NF vars)
strCons [NPrimVal fc (Ch x), NPrimVal _ (Str y)]
    = Just (NPrimVal fc (Str (strCons x y)))
strCons _ = Nothing

strAppend : Vect 2 (NF vars) -> Maybe (NF vars)
strAppend [NPrimVal fc (Str x), NPrimVal _ (Str y)]
    = Just (NPrimVal fc (Str (x ++ y)))
strAppend _ = Nothing

strReverse : Vect 1 (NF vars) -> Maybe (NF vars)
strReverse [NPrimVal fc (Str x)]
    = Just (NPrimVal fc (Str (reverse x)))
strReverse _ = Nothing

strSubstr : Vect 3 (NF vars) -> Maybe (NF vars)
strSubstr [NPrimVal fc (I start), NPrimVal _ (I len), NPrimVal _ (Str str)]
    = Just (NPrimVal fc (Str (prim__strSubstr start len str)))
strSubstr _ = Nothing

add : Constant -> Constant -> Maybe Constant
add (BI x) (BI y) = pure $ BI (x + y)
add (I x) (I y) = pure $ I (x + y)
add (B8 x) (B8 y) = pure $ B8 $ (x + y) `mod` b8max
add (B16 x) (B16 y) = pure $ B16 $ (x + y) `mod` b16max
add (B32 x) (B32 y) = pure $ B32 $ (x + y) `mod` b32max
add (B64 x) (B64 y) = pure $ B64 $ (x + y) `mod` b64max
add (Ch x) (Ch y) = pure $ Ch (cast (cast {to=Int} x + cast y))
add (Db x) (Db y) = pure $ Db (x + y)
add _ _ = Nothing

sub : Constant -> Constant -> Maybe Constant
sub (BI x) (BI y) = pure $ BI (x - y)
sub (I x) (I y) = pure $ I (x - y)
sub (Ch x) (Ch y) = pure $ Ch (cast (cast {to=Int} x - cast y))
sub (Db x) (Db y) = pure $ Db (x - y)
sub _ _ = Nothing

mul : Constant -> Constant -> Maybe Constant
mul (BI x) (BI y) = pure $ BI (x * y)
mul (B8 x) (B8 y) = pure $ B8 $ (x * y) `mod` b8max
mul (B16 x) (B16 y) = pure $ B16 $ (x * y) `mod` b16max
mul (B32 x) (B32 y) = pure $ B32 $ (x * y) `mod` b32max
mul (B64 x) (B64 y) = pure $ B64 $ (x * y) `mod` b64max
mul (I x) (I y) = pure $ I (x * y)
mul (Db x) (Db y) = pure $ Db (x * y)
mul _ _ = Nothing

div : Constant -> Constant -> Maybe Constant
div (BI x) (BI 0) = Nothing
div (BI x) (BI y) = pure $ BI (assert_total (x `div` y))
div (I x) (I 0) = Nothing
div (I x) (I y) = pure $ I (assert_total (x `div` y))
div (Db x) (Db y) = pure $ Db (x / y)
div _ _ = Nothing

mod : Constant -> Constant -> Maybe Constant
mod (BI x) (BI 0) = Nothing
mod (BI x) (BI y) = pure $ BI (assert_total (x `mod` y))
mod (I x) (I 0) = Nothing
mod (I x) (I y) = pure $ I (assert_total (x `mod` y))
mod _ _ = Nothing

shiftl : Constant -> Constant -> Maybe Constant
shiftl (I x) (I y) = pure $ I (shiftL x y)
shiftl (BI x) (BI y) = pure $ BI (prim__shl_Integer x y)
shiftl (B8 x) (B8 y) = pure $ B8 $ (prim__shl_Int x y) `mod` b8max
shiftl (B16 x) (B16 y) = pure $ B16 $ (prim__shl_Int x y) `mod` b16max
shiftl (B32 x) (B32 y) = pure $ B32 $ (prim__shl_Int x y) `mod` b32max
shiftl (B64 x) (B64 y) = pure $ B64 $ (prim__shl_Integer x y) `mod` b64max
shiftl _ _ = Nothing

shiftr : Constant -> Constant -> Maybe Constant
shiftr (I x) (I y) = pure $ I (shiftR x y)
shiftr (BI x) (BI y) = pure $ BI (prim__shr_Integer x y)
shiftr (B8 x) (B8 y) = pure $ B8 $ (prim__shr_Int x y)
shiftr (B16 x) (B16 y) = pure $ B16 $ (prim__shr_Int x y)
shiftr (B32 x) (B32 y) = pure $ B32 $ (prim__shr_Int x y)
shiftr (B64 x) (B64 y) = pure $ B64 $ (prim__shr_Integer x y)
shiftr _ _ = Nothing

band : Constant -> Constant -> Maybe Constant
band (I x) (I y) = pure $ I (prim__and_Int x y)
band (BI x) (BI y) = pure $ BI (prim__and_Integer x y)
band (B8 x) (B8 y) = pure $ B8 (prim__and_Int x y)
band (B16 x) (B16 y) = pure $ B16 (prim__and_Int x y)
band (B32 x) (B32 y) = pure $ B32 (prim__and_Int x y)
band (B64 x) (B64 y) = pure $ B64 (prim__and_Integer x y)
band _ _ = Nothing

bor : Constant -> Constant -> Maybe Constant
bor (I x) (I y) = pure $ I (prim__or_Int x y)
bor (BI x) (BI y) = pure $ BI (prim__or_Integer x y)
bor (B8 x) (B8 y) = pure $ B8 (prim__or_Int x y)
bor (B16 x) (B16 y) = pure $ B16 (prim__or_Int x y)
bor (B32 x) (B32 y) = pure $ B32 (prim__or_Int x y)
bor (B64 x) (B64 y) = pure $ B64 (prim__or_Integer x y)
bor _ _ = Nothing

bxor : Constant -> Constant -> Maybe Constant
bxor (I x) (I y) = pure $ I (prim__xor_Int x y)
bxor (B8 x) (B8 y) = pure $ B8 (prim__xor_Int x y)
bxor (B16 x) (B16 y) = pure $ B16 (prim__xor_Int x y)
bxor (B32 x) (B32 y) = pure $ B32 (prim__xor_Int x y)
bxor _ _ = Nothing

neg : Constant -> Maybe Constant
neg (BI x) = pure $ BI (-x)
neg (I x) = pure $ I (-x)
neg (Db x) = pure $ Db (-x)
neg _ = Nothing

toInt : Bool -> Constant
toInt True = I 1
toInt False = I 0

lt : Constant -> Constant -> Maybe Constant
lt (I x) (I y) = pure $ toInt (x < y)
lt (BI x) (BI y) = pure $ toInt (x < y)
lt (B8 x) (B8 y) = pure $ toInt (x < y)
lt (B16 x) (B16 y) = pure $ toInt (x < y)
lt (B32 x) (B32 y) = pure $ toInt (x < y)
lt (B64 x) (B64 y) = pure $ toInt (x < y)
lt (Str x) (Str y) = pure $ toInt (x < y)
lt (Ch x) (Ch y) = pure $ toInt (x < y)
lt (Db x) (Db y) = pure $ toInt (x < y)
lt _ _ = Nothing

lte : Constant -> Constant -> Maybe Constant
lte (I x) (I y) = pure $ toInt (x <= y)
lte (BI x) (BI y) = pure $ toInt (x <= y)
lte (B8 x) (B8 y) = pure $ toInt (x <= y)
lte (B16 x) (B16 y) = pure $ toInt (x <= y)
lte (B32 x) (B32 y) = pure $ toInt (x <= y)
lte (B64 x) (B64 y) = pure $ toInt (x <= y)
lte (Str x) (Str y) = pure $ toInt (x <= y)
lte (Ch x) (Ch y) = pure $ toInt (x <= y)
lte (Db x) (Db y) = pure $ toInt (x <= y)
lte _ _ = Nothing

eq : Constant -> Constant -> Maybe Constant
eq (I x) (I y) = pure $ toInt (x == y)
eq (BI x) (BI y) = pure $ toInt (x == y)
eq (B8 x) (B8 y) = pure $ toInt (x == y)
eq (B16 x) (B16 y) = pure $ toInt (x == y)
eq (B32 x) (B32 y) = pure $ toInt (x == y)
eq (B64 x) (B64 y) = pure $ toInt (x == y)
eq (Str x) (Str y) = pure $ toInt (x == y)
eq (Ch x) (Ch y) = pure $ toInt (x == y)
eq (Db x) (Db y) = pure $ toInt (x == y)
eq _ _ = Nothing

gte : Constant -> Constant -> Maybe Constant
gte (I x) (I y) = pure $ toInt (x >= y)
gte (BI x) (BI y) = pure $ toInt (x >= y)
gte (B8 x) (B8 y) = pure $ toInt (x >= y)
gte (B16 x) (B16 y) = pure $ toInt (x >= y)
gte (B32 x) (B32 y) = pure $ toInt (x >= y)
gte (B64 x) (B64 y) = pure $ toInt (x >= y)
gte (Str x) (Str y) = pure $ toInt (x >= y)
gte (Ch x) (Ch y) = pure $ toInt (x >= y)
gte (Db x) (Db y) = pure $ toInt (x >= y)
gte _ _ = Nothing

gt : Constant -> Constant -> Maybe Constant
gt (I x) (I y) = pure $ toInt (x > y)
gt (BI x) (BI y) = pure $ toInt (x > y)
gt (B8 x) (B8 y) = pure $ toInt (x > y)
gt (B16 x) (B16 y) = pure $ toInt (x > y)
gt (B32 x) (B32 y) = pure $ toInt (x > y)
gt (B64 x) (B64 y) = pure $ toInt (x > y)
gt (Str x) (Str y) = pure $ toInt (x > y)
gt (Ch x) (Ch y) = pure $ toInt (x > y)
gt (Db x) (Db y) = pure $ toInt (x > y)
gt _ _ = Nothing

doubleOp : (Double -> Double) -> Vect 1 (NF vars) -> Maybe (NF vars)
doubleOp f [NPrimVal fc (Db x)] = Just (NPrimVal fc (Db (f x)))
doubleOp f _ = Nothing

doubleExp : Vect 1 (NF vars) -> Maybe (NF vars)
doubleExp = doubleOp exp

doubleLog : Vect 1 (NF vars) -> Maybe (NF vars)
doubleLog = doubleOp log

doubleSin : Vect 1 (NF vars) -> Maybe (NF vars)
doubleSin = doubleOp sin

doubleCos : Vect 1 (NF vars) -> Maybe (NF vars)
doubleCos = doubleOp cos

doubleTan : Vect 1 (NF vars) -> Maybe (NF vars)
doubleTan = doubleOp tan

doubleASin : Vect 1 (NF vars) -> Maybe (NF vars)
doubleASin = doubleOp asin

doubleACos : Vect 1 (NF vars) -> Maybe (NF vars)
doubleACos = doubleOp acos

doubleATan : Vect 1 (NF vars) -> Maybe (NF vars)
doubleATan = doubleOp atan

doubleSqrt : Vect 1 (NF vars) -> Maybe (NF vars)
doubleSqrt = doubleOp sqrt

doubleFloor : Vect 1 (NF vars) -> Maybe (NF vars)
doubleFloor = doubleOp floor

doubleCeiling : Vect 1 (NF vars) -> Maybe (NF vars)
doubleCeiling = doubleOp ceiling

-- Only reduce for concrete values
believeMe : Vect 3 (NF vars) -> Maybe (NF vars)
believeMe [_, _, val@(NDCon _ _ _ _ _)] = Just val
believeMe [_, _, val@(NTCon _ _ _ _ _)] = Just val
believeMe [_, _, val@(NPrimVal _ _)] = Just val
believeMe [_, _, NType fc] = Just (NType fc)
believeMe [_, _, val] = Nothing

constTy : Constant -> Constant -> Constant -> ClosedTerm
constTy a b c
    = let arr = linFnType emptyFC in
    PrimVal emptyFC a `arr` (PrimVal emptyFC b `arr` PrimVal emptyFC c)

constTy3 : Constant -> Constant -> Constant -> Constant -> ClosedTerm
constTy3 a b c d
    = let arr = linFnType emptyFC in
    PrimVal emptyFC a `arr`
         (PrimVal emptyFC b `arr`
             (PrimVal emptyFC c `arr` PrimVal emptyFC d))

predTy : Constant -> Constant -> ClosedTerm
predTy a b = let arr = linFnType emptyFC in
             PrimVal emptyFC a `arr` PrimVal emptyFC b

arithTy : Constant -> ClosedTerm
arithTy t = constTy t t t

cmpTy : Constant -> ClosedTerm
cmpTy t = constTy t t IntType

doubleTy : ClosedTerm
doubleTy = predTy DoubleType DoubleType

believeMeTy : ClosedTerm
believeMeTy
    = Bind emptyFC (UN "a") (Pi emptyFC erased Explicit (TType emptyFC)) $
      Bind emptyFC (UN "b") (Pi emptyFC erased Explicit (TType emptyFC)) $
      Bind emptyFC (UN "x") (Pi emptyFC top Explicit (Local emptyFC Nothing _ (Later First))) $
      Local emptyFC Nothing _ (Later First)

crashTy : ClosedTerm
crashTy
    = Bind emptyFC (UN "a") (Pi emptyFC erased Explicit (TType emptyFC)) $
      Bind emptyFC (UN "msg") (Pi emptyFC top Explicit (PrimVal emptyFC StringType)) $
      Local emptyFC Nothing _ (Later First)

castTo : Constant -> Vect 1 (NF vars) -> Maybe (NF vars)
castTo IntType = castInt
castTo IntegerType = castInteger
castTo Bits8Type = castBits8
castTo Bits16Type = castBits16
castTo Bits32Type = castBits32
castTo Bits64Type = castBits64
castTo StringType = castString
castTo CharType = castChar
castTo DoubleType = castDouble
castTo _ = const Nothing

export
getOp : PrimFn arity ->
        {vars : List Name} -> Vect arity (NF vars) -> Maybe (NF vars)
getOp (Add ty) = binOp add
getOp (Sub ty) = binOp sub
getOp (Mul ty) = binOp mul
getOp (Div ty) = binOp div
getOp (Mod ty) = binOp mod
getOp (Neg ty) = unaryOp neg
getOp (ShiftL ty) = binOp shiftl
getOp (ShiftR ty) = binOp shiftr

getOp (BAnd ty) = binOp band
getOp (BOr ty) = binOp bor
getOp (BXOr ty) = binOp bxor

getOp (LT ty) = binOp lt
getOp (LTE ty) = binOp lte
getOp (EQ ty) = binOp eq
getOp (GTE ty) = binOp gte
getOp (GT ty) = binOp gt

getOp StrLength = strLength
getOp StrHead = strHead
getOp StrTail = strTail
getOp StrIndex = strIndex
getOp StrCons = strCons
getOp StrAppend = strAppend
getOp StrReverse = strReverse
getOp StrSubstr = strSubstr

getOp DoubleExp = doubleExp
getOp DoubleLog = doubleLog
getOp DoubleSin = doubleSin
getOp DoubleCos = doubleCos
getOp DoubleTan = doubleTan
getOp DoubleASin = doubleASin
getOp DoubleACos = doubleACos
getOp DoubleATan = doubleATan
getOp DoubleSqrt = doubleSqrt
getOp DoubleFloor = doubleFloor
getOp DoubleCeiling = doubleCeiling

getOp (Cast _ y) = castTo y
getOp BelieveMe = believeMe

getOp _ = const Nothing

prim : String -> Name
prim str = UN $ "prim__" ++ str

export
opName : PrimFn arity -> Name
opName (Add ty) = prim $ "add_" ++ show ty
opName (Sub ty) = prim $ "sub_" ++ show ty
opName (Mul ty) = prim $ "mul_" ++ show ty
opName (Div ty) = prim $ "div_" ++ show ty
opName (Mod ty) = prim $ "mod_" ++ show ty
opName (Neg ty) = prim $ "negate_" ++ show ty
opName (ShiftL ty) = prim $ "shl_" ++ show ty
opName (ShiftR ty) = prim $ "shr_" ++ show ty
opName (BAnd ty) = prim $ "and_" ++ show ty
opName (BOr ty) = prim $ "or_" ++ show ty
opName (BXOr ty) = prim $ "xor_" ++ show ty
opName (LT ty) = prim $ "lt_" ++ show ty
opName (LTE ty) = prim $ "lte_" ++ show ty
opName (EQ ty) = prim $ "eq_" ++ show ty
opName (GTE ty) = prim $ "gte_" ++ show ty
opName (GT ty) = prim $ "gt_" ++ show ty
opName StrLength = prim "strLength"
opName StrHead = prim "strHead"
opName StrTail = prim "strTail"
opName StrIndex = prim "strIndex"
opName StrCons = prim "strCons"
opName StrAppend = prim "strAppend"
opName StrReverse = prim "strReverse"
opName StrSubstr = prim "strSubstr"
opName DoubleExp = prim "doubleExp"
opName DoubleLog = prim "doubleLog"
opName DoubleSin = prim "doubleSin"
opName DoubleCos = prim "doubleCos"
opName DoubleTan = prim "doubleTan"
opName DoubleASin = prim "doubleASin"
opName DoubleACos = prim "doubleACos"
opName DoubleATan = prim "doubleATan"
opName DoubleSqrt = prim "doubleSqrt"
opName DoubleFloor = prim "doubleFloor"
opName DoubleCeiling = prim "doubleCeiling"
opName (Cast x y) = prim $ "cast_" ++ show x ++ show y
opName BelieveMe = prim $ "believe_me"
opName Crash = prim $ "crash"

export
allPrimitives : List Prim
allPrimitives =
    map (\t => MkPrim (Add t) (arithTy t) isTotal) [IntType, IntegerType, Bits8Type, Bits16Type, Bits32Type, Bits64Type, CharType, DoubleType] ++
    map (\t => MkPrim (Sub t) (arithTy t) isTotal) [IntType, IntegerType, CharType, DoubleType] ++
    map (\t => MkPrim (Mul t) (arithTy t) isTotal) [IntType, IntegerType, Bits8Type, Bits16Type, Bits32Type, Bits64Type, DoubleType] ++
    map (\t => MkPrim (Div t) (arithTy t) notCovering) [IntType, IntegerType, Bits8Type, Bits16Type, Bits32Type, Bits64Type, DoubleType] ++
    map (\t => MkPrim (Mod t) (arithTy t) notCovering) [IntType, IntegerType, Bits8Type, Bits16Type, Bits32Type, Bits64Type] ++
    map (\t => MkPrim (Neg t) (predTy t t) isTotal) [IntType, IntegerType, DoubleType] ++
    map (\t => MkPrim (ShiftL t) (arithTy t) isTotal) [IntType, IntegerType, Bits8Type, Bits16Type, Bits32Type, Bits64Type] ++
    map (\t => MkPrim (ShiftR t) (arithTy t) isTotal) [IntType, IntegerType, Bits8Type, Bits16Type, Bits32Type, Bits64Type] ++

    map (\t => MkPrim (BAnd t) (arithTy t) isTotal) [IntType, IntegerType, Bits8Type, Bits16Type, Bits32Type, Bits64Type] ++
    map (\t => MkPrim (BOr t) (arithTy t) isTotal) [IntType, IntegerType, Bits8Type, Bits16Type, Bits32Type, Bits64Type] ++
    map (\t => MkPrim (BXOr t) (arithTy t) isTotal) [IntType, Bits8Type, Bits16Type, Bits32Type] ++

    map (\t => MkPrim (LT t) (cmpTy t) isTotal) [IntType, IntegerType, CharType, DoubleType, StringType, Bits8Type, Bits16Type, Bits32Type, Bits64Type] ++
    map (\t => MkPrim (LTE t) (cmpTy t) isTotal) [IntType, IntegerType, CharType, DoubleType, StringType, Bits8Type, Bits16Type, Bits32Type, Bits64Type] ++
    map (\t => MkPrim (EQ t) (cmpTy t) isTotal) [IntType, IntegerType, CharType, DoubleType, StringType, Bits8Type, Bits16Type, Bits32Type, Bits64Type] ++
    map (\t => MkPrim (GTE t) (cmpTy t) isTotal) [IntType, IntegerType, CharType, DoubleType, StringType, Bits8Type, Bits16Type, Bits32Type, Bits64Type] ++
    map (\t => MkPrim (GT t) (cmpTy t) isTotal) [IntType, IntegerType, CharType, DoubleType, StringType, Bits8Type, Bits16Type, Bits32Type, Bits64Type] ++

    [MkPrim StrLength (predTy StringType IntType) isTotal,
     MkPrim StrHead (predTy StringType CharType) notCovering,
     MkPrim StrTail (predTy StringType StringType) notCovering,
     MkPrim StrIndex (constTy StringType IntType CharType) notCovering,
     MkPrim StrCons (constTy CharType StringType StringType) isTotal,
     MkPrim StrAppend (arithTy StringType) isTotal,
     MkPrim StrReverse (predTy StringType StringType) isTotal,
     MkPrim StrSubstr (constTy3 IntType IntType StringType StringType) isTotal,
     MkPrim BelieveMe believeMeTy isTotal,
     MkPrim Crash crashTy notCovering] ++

    [MkPrim DoubleExp doubleTy isTotal,
     MkPrim DoubleLog doubleTy isTotal,
     MkPrim DoubleSin doubleTy isTotal,
     MkPrim DoubleCos doubleTy isTotal,
     MkPrim DoubleTan doubleTy isTotal,
     MkPrim DoubleASin doubleTy isTotal,
     MkPrim DoubleACos doubleTy isTotal,
     MkPrim DoubleATan doubleTy isTotal,
     MkPrim DoubleSqrt doubleTy isTotal,
     MkPrim DoubleFloor doubleTy isTotal,
     MkPrim DoubleCeiling doubleTy isTotal] ++

    map (\t => MkPrim (Cast t StringType) (predTy t StringType) isTotal) [IntType, IntegerType, Bits8Type, Bits16Type, Bits32Type, Bits64Type, CharType, DoubleType] ++
    map (\t => MkPrim (Cast t IntegerType) (predTy t IntegerType) isTotal) [StringType, IntType, Bits8Type, Bits16Type, Bits32Type, Bits64Type, CharType, DoubleType] ++
    map (\t => MkPrim (Cast t IntType) (predTy t IntType) isTotal) [StringType, IntegerType, Bits8Type, Bits16Type, Bits32Type, Bits64Type, CharType, DoubleType] ++
    map (\t => MkPrim (Cast t DoubleType) (predTy t DoubleType) isTotal) [StringType, IntType, IntegerType] ++
    map (\t => MkPrim (Cast t CharType) (predTy t CharType) isTotal) [StringType, IntType] ++

    map (\t => MkPrim (Cast t Bits8Type) (predTy t Bits8Type) isTotal) [IntType, IntegerType, Bits16Type, Bits32Type, Bits64Type] ++
    map (\t => MkPrim (Cast t Bits16Type) (predTy t Bits16Type) isTotal) [IntType, IntegerType, Bits8Type, Bits32Type, Bits64Type] ++
    map (\t => MkPrim (Cast t Bits32Type) (predTy t Bits32Type) isTotal) [IntType, IntegerType, Bits8Type, Bits16Type, Bits64Type] ++
    map (\t => MkPrim (Cast t Bits64Type) (predTy t Bits64Type) isTotal) [IntType, IntegerType, Bits8Type, Bits16Type, Bits32Type]


module Data.Time.Clock.Internal.DiffTime

import Data.Time.Clock.Internal.Fixed as F

--import Data.Data
--import Data.Fixed
--import Data.Ratio ((%))
--import Data.Typeable

||| This is a length of time, as measured by a clock.
||| Conversion functions will treat it as seconds.
||| It has a precision of 10^-12 s.
public export
data DiffTime = MkDiffTime Pico

export
Enum DiffTime where
  pred (MkDiffTime x) = MkDiffTime (pred x)
  toNat (MkDiffTime x) = toNat x
  fromNat x = MkDiffTime (fromNat x)

export
Show DiffTime where
    show (MkDiffTime t) = show t

export
Eq DiffTime where
  (MkDiffTime a) == (MkDiffTime b) = a == b

export
Ord DiffTime where
  compare (MkDiffTime a) (MkDiffTime b) = compare a b

add: DiffTime -> DiffTime -> DiffTime
add (MkDiffTime x) (MkDiffTime y) = MkDiffTime (x + y)

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

minus: DiffTime -> DiffTime -> DiffTime
minus (MkDiffTime x) (MkDiffTime y) = MkDiffTime (x - y)

negate: DiffTime -> DiffTime
negate (MkDiffTime x) = MkDiffTime (negate x)

abs : DiffTime-> DiffTime
abs (MkDiffTime x) = MkDiffTime (abs x)

fromInteger : Integer -> DiffTime
fromInteger x = MkDiffTime (MkFixed x)

mult: DiffTime -> DiffTime -> DiffTime
mult (MkDiffTime x) (MkDiffTime y) = MkDiffTime (x * y)

(*): DiffTime -> DiffTime -> DiffTime
(*) = mult

toRational: DiffTime -> Double
toRational (MkDiffTime x) = (toRational x)

fracDiv: DiffTime -> DiffTime -> DiffTime
fracDiv (MkDiffTime x) (MkDiffTime y) = MkDiffTime (fracDiv x y)

(/): DiffTime -> DiffTime -> DiffTime
(/) = fracDiv

recip : DiffTime -> DiffTime
recip (MkDiffTime x) = MkDiffTime (recip x)

secondsToDiffTime: Integer -> DiffTime
secondsToDiffTime = fromInteger

export
picosecondsToDiffTime: Integer -> DiffTime
picosecondsToDiffTime x = MkDiffTime (MkFixed x)

export
diffTimeToPicoseconds : DiffTime -> Integer
diffTimeToPicoseconds (MkDiffTime (MkFixed x)) = x


module Dep

interface Monad m => FooBar m where
  Foo : {0 a : Type} -> a -> m a -> Type
  Bar : {0 A : Type} -> m A -> Type
  foo : {0 A : Type} -> (x : A) -> (ma : m A) -> Foo x ma -> Bar ma


-- ---------------------------------------------------------------- [ Sign.idr ]
-- Module      :
-- Description :
-- Copyright   : (c) Jan de Muijnck-Hughes
-- License     : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
module Crypto.Std.Sign

import Crypto.Common
import Crypto.Message

import Crypto.Std.Key

||| Representation of a digital signature scheme.
class SignScheme s where
  ||| Generate a sign and verify key pair.
  signKeyGen : (Key Public Sign n, Key Private Sign m)

  ||| Sign a message and return a signed message.
  |||
  ||| @ sigkey The senders signing key.
  ||| @ msg The message to be signed.
  signMsg : (sigkey : Key Private Sign m)
            -> (msg : Vect a Bits32)
            -> Signed b

  ||| Verify a signed message and return the message.
  |||
  ||| @ verkey The senders verification key.
  ||| @ sigmsg The signed message.
  verifyMsg : (verkey : Key Public Sign n)
              -> (sigmsg : Signed b)
              -> Maybe (Vect a Bits32)

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


module Issue758

-- introduce linear bind and linear pure
interface LMonad m where
  pure : (1 _ : a) -> m a
  (>>=) : (1 _ : m a) -> (1 _ : (1 _ : a) -> m b) -> m b

(>>) : LMonad m => (1 _ : m ()) -> (1 _ : m a) -> m a
ma >> mb = ma >>= \ () => mb

fail : LMonad m => (1 _ : m ((1 _ : a) -> b)) -> (1 _ : a) -> m b
fail ma a = do f <- ma
               ?what_is_f
               pure (f a)


module Data.Tree

-- Implementation heavily inspired by Haskell's Data.Tree

%default total
%access public export

mutual
  record Tree a where
    constructor Node
    rootLabel : a
    subForest : Forest a

  Forest : Type -> Type
  Forest a = List (Tree a)

Eq a => Eq (Tree a) where
  (Node rootLabel1 subForest1) == (Node rootLabel2 subForest2) =
    rootLabel1 == rootLabel2 &&
     isSubForestsEqual subForest1 subForest2
      where
        isSubForestsEqual : Forest a -> Forest a -> Bool
        isSubForestsEqual [] [] = True
        isSubForestsEqual [] (y :: ys) = False
        isSubForestsEqual (x :: xs) [] = False
        isSubForestsEqual (x :: xs) (y :: ys) = x == y && isSubForestsEqual xs ys

Functor Tree where
  map func (Node rootLabel subForest) =
    Node (func rootLabel) (mapSubForest subForest)
      where
        mapSubForest : Forest a -> Forest b
        mapSubForest [] = []
        mapSubForest (x :: xs) = map func x :: mapSubForest xs

Show a => Show (Tree a) where
  show (Node rootLabel subForest) =
    "Node " ++ show rootLabel ++ " " ++ showSubForest subForest
      where
        showRestOfSubForest : Forest a -> String
        showRestOfSubForest [] = ""
        showRestOfSubForest (x :: xs) = ", " ++ show x ++ showRestOfSubForest xs

        showSubForest : Forest a -> String
        showSubForest [] = "[]"
        showSubForest (x :: xs) = "[" ++ show x ++ showRestOfSubForest xs ++ "]"

partial
draw : Tree String -> List String
draw (Node x ts0) = lines x ++ drawSubTrees ts0
  where
    shift : String -> String -> List String -> List String
    shift first other xs =
      zipWith (++) (first :: take (length xs `minus` 1) (repeat other)) xs

    drawSubTrees : Forest String -> List String
    drawSubTrees [] = []
    drawSubTrees [t] =
        "|" :: shift "`- " "   " (draw t)
    drawSubTrees (t :: ts) =
        "|" :: shift "+- " "|  " (draw t) ++ drawSubTrees ts

partial
drawTree : Tree String -> String
drawTree = unlines . draw

partial
drawForest : Forest String -> String
drawForest  = unlines . map drawTree


module Main

import Conway.Conway
import Conway.Graphics
import Conway.RLE

import Effect.File

import Data.Vect

showCW : Conway m n -> String
showCW (MkConway v) = concat $ map (\row => showRow row ++ "\n") v
  where showRow : Vect n CellState -> String
        showRow v = concat $ map (\cs => case cs of
                            Alive => ". "
                            Dead  => "  "
                        ) v

loop : Conway m n -> IO ()
loop cw = do
       putStrLn $ showCW cw
       getLine
       loop $ iterateGame cw

maxLength : List (List a) -> Nat
maxLength xs = maxLength' 0 xs
  where maxLength' : Nat -> List (List a) -> Nat
        maxLength' n [] = n
        maxLength' n (x::xs) = maxLength' (max n (length x)) xs

repeatN : (n : Nat) -> a -> Vect n a
repeatN Z _ = []
repeatN (S n) a = (a::(repeatN n a))

lToV : (n : Nat) -> List (List CellState) -> List (Vect n CellState)
lToV n [] = []
lToV n ys = map (\x => f n x) ys
  where f : (n : Nat) -> List CellState -> Vect n CellState
        f Z _ = []
        f (S n) [] = (Dead::(f n []))
        f (S n) (y::ys) = (y::(f n ys))

main : IO ()
main = do
  args <- getArgs
  let fNameM = index' 1 args
  case fNameM of
    Nothing => print "Usage ./Conway 'filename'"
    Just fName => do
        cwM <- readCFile fName
        case cwM of
          Nothing => print "Error in converting file contents\n"
          Just cw => do
            let lVec = lToV (maxLength cw) cw
            let vec = fromList lVec
            let conway = MkConway vec
            conwayLoop conway

 {-
  conwayLoop cw
  where
      row1 : Vect 4 CellState
      row1 = fromList [Dead, Alive, Dead, Dead]

      row2 : Vect 4 CellState
      row2 = fromList [Dead, Alive, Dead, Dead]

      row3 : Vect 4 CellState
      row3 = fromList [Dead, Alive, Dead, Dead]

      row4 : Vect 4 CellState
      row4 = fromList [Dead, Dead, Dead, Dead]

      v : Vect 4 (Vect 4 CellState)
      v = fromList [row1, row2, row3, row4]

      cw : Conway 4 4
      cw = MkConway v
  -}


module Data.Map.AssocList import Data.Map

%access public
%default total

AListMap : Type -> Type -> Type
AListMap k v = List (k,v)

instance Map AListMap where
  empty = Nil
  fromList = id
  toList = id
  listKeys = map fst
  listValues = map snd

  fromVect = List.toList
  toVect xs = (length xs ** Vect.fromList xs)
  vectKeys xs = let xs' = map fst xs in (length xs' ** Vect.fromList xs')
  vectValues xs = let xs' = map snd xs in (length xs' ** Vect.fromList xs')

  grub k xs = map snd $ filter (\x => fst x == k) xs
  lookup k xs = map snd $ find (\x => fst x == k) xs

  insert = (::)
  erase k = filter (\x => fst x /= k)
  eraseBy f = filter (not . f)


module Test

corecord Stream' : Type -> Type where
  hd : Stream' a -> a
  tl : Stream' a -> Later' (Stream' a)
  constructor StreamCons

fix : (Later' a -> a) -> a
fix f = f(Next (fix f))

pfix : ((a -> Later' b) -> (a -> b)) -> (a -> b)
pfix f = fix(\g => f (\x => compose {n=Now} g (Next x)))


module BinaryFormats

import Control.Pipeline
import Data.Vect
import Data.ZZ

import BinaryFormats.Data.Bit
import BinaryFormats.Data.List

%default total

mutual
    ||| A universe of binary data formats
    data Format : Type where
        FBad : Format
        FEnd : Format
        FBit : Format
        FByte : Format
        FChar : Format
        FU8 : Format
        FU16 : Format -- TODO: Endianness
        FU32 : Format -- TODO: Endianness
        FS8 : Format
        FS16 : Format -- TODO: Endianness
        FS32 : Format -- TODO: Endianness
        FRef : Format
        FPtr : Nat -> List Bit -> Format -> Format
        FVect : Nat -> Format -> Format
        FPlus : Format -> Format -> Format
        FSkip : Format -> Format -> Format
        FRead : (f : Format) -> (embed f -> Format) -> Format

    ||| Interprets `Format` as an Idris type
    embed : Format -> Type
    embed FBad = Void
    embed FEnd = Unit
    embed FBit = Bit
    embed FByte = Bits8
    embed FChar = Char
    embed FU8 = Nat
    embed FU16 = Nat
    embed FU32 = Nat
    embed FS8 = ZZ
    embed FS16 = ZZ
    embed FS32 = ZZ
    embed FRef = List Bit
    embed (FPtr _ _ f) = Lazy (Maybe (embed f))
    embed (FVect n a) = Vect n (embed a)
    embed (FPlus f1 f2) = Either (embed f1) (embed f2)
    embed (FSkip _ f) = embed f
    embed (FRead f1 f2) = (f : embed f1 ** embed (f2 f))

||| Require a predicate to be satisfied
satisfy : (f : Format) -> (embed f -> Bool) -> Format
satisfy f pred =
    FRead f  (\x => if pred x then FEnd else FBad)

||| Require a character literal to be parsed
char : Char -> Format
char c =
    satisfy FChar ((==) c)

||| Sequence two binary formats, one after the other
(>>) : Format -> Format -> Format
(>>) x f = FSkip x f

||| Parsed one format and then use it to figure out what to parse next
(>>=) : (f : Format) -> (embed f -> Format) -> Format
(>>=) x f = FRead x f

Parser : Type -> Type
Parser a = (bits : List Bit) -> Maybe (a, List Bit)

parseBit : Parser Bit
parseBit [] = Nothing
parseBit (bit :: bits) = Just (bit, bits)

parseUNum : {a : Type} -> Num a => Nat -> Parser a
parseUNum size bits =
    trySplitAt size bits
        |> map (\(headBits, tailBits) => (go headBits 0, tailBits))
    where
        go : {a : Type} -> Num a => List Bit -> a -> a
        go [] acc = acc
        go (O :: bits) acc = go bits (2 * acc)
        go (I :: bits) acc = go bits (1 + (2 * acc))

parseUInt : Nat -> Parser Nat
parseUInt = parseUNum

-- FXME: Two's complement?
parseSInt : Nat -> Parser ZZ
parseSInt Z bits = Just (0, bits)
parseSInt (S _) [] = Nothing
parseSInt (S size) (O :: bits) = parseUInt size bits |> map (\(n, bits') => (Pos n, bits'))
parseSInt (S size) (I :: bits) = parseUInt size bits |> map (\(n, bits') => (negNat n, bits'))

parseChar : Parser Char
parseChar bits =
    parseUInt 16 bits  -- Idris' `Char`s are supposedly 2 bytes wide
        |> map (\(n, bits') => (chr (toIntNat n), bits'))

mutual
    parseVect : {n : Nat} -> (f : Format) -> Parser (Vect n (embed f))
    parseVect {n} f = rewrite plusCommutative Z n in go n []
        where
            go : {m : Nat} -> (n : Nat) -> Vect m (embed f) -> Parser (Vect (n + m) (embed f))
            go {m} Z acc bits = Just (reverse acc, bits)
            go {m} (S k) acc bits with (parse f bits)
                | Nothing = Nothing
                | Just (elem, bits'') =
                    rewrite plusSuccRightSucc k m in go k (elem :: acc) bits''

    ||| Interpret a binary format specification as a parser
    parse : (f : Format) -> Parser (embed f)
    parse FBad bits = Nothing
    parse FEnd bits = Just ((), bits)
    parse FBit bits = parseBit bits
    parse FByte bits = parseUNum 8 bits
    parse FChar bits = parseChar bits
    parse FU8 bits = parseUInt 8 bits
    parse FU16 bits = parseUInt 16 bits
    parse FU32 bits = parseUInt 32 bits
    parse FS8 bits = parseSInt 8 bits
    parse FS16 bits = parseSInt 16 bits
    parse FS32 bits = parseSInt 32 bits
    parse FRef bits = Just (bits, bits)
    parse (FPtr offset refBits f) bits with (tryDrop offset refBits)
        | Nothing = Nothing
        | Just refBits' = Just (Delay (parse f refBits' |> map fst), bits)
    parse (FVect n f) bits = parseVect f bits
    parse (FPlus f1 f2) bits with (parse f1 bits)
        | (Just (x, bits')) = Just (Left x, bits')
        | Nothing with (parse f2 bits)
            | (Just (y, bits')) = Just (Right y, bits')
            | Nothing = Nothing
    parse (FSkip f1 f2) bits with (parse f1 bits)
        | Nothing = Nothing
        | (Just (x, bits')) = parse f2 bits'
    parse (FRead f1 f2) bits with (parse f1 bits)
        | Nothing = Nothing
        | (Just (x, bits')) with (parse (f2 x) bits')
            | Nothing = Nothing
            | Just (y, bits'') = Just ((x ** y), bits'')

||| PBM binary format
pbm : Format
pbm = do
    char 'p'
    char '4'
    char ' '
    n <- FU16
    char ' '
    m <- FU16
    char '\n'
    bs <- FVect n (FVect m FBit)
    FEnd

||| Parse PBM data from a string of bits
parsePbm : Parser (embed BinaryFormats.pbm)
parsePbm = parse pbm

test : Format
test = do
    x <- FBit
    case x of
        O => FU8
        I => FS8

testPtr : Format
testPtr = do
    start <- FRef
    offset <- FU16
    ptr <- FPtr offset start <| do
        namesLen <- FU16
        names <- FVect namesLen <| do
            nameLen <- FU16
            name <- FVect nameLen FChar
            FEnd
        FEnd
    FEnd


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

import public Control.Monad.Ref
import        Data.Vect
import public Data.UniverseR

%default total
%access public export

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

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

-- Types --

data Cell : {u : Universe t} -> (a : t) -> Type where
  MkCell : Nat -> Cell a

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

  New   : (x : typeOf @{u} a) -> RefT m (Cell a)
  Read  : (l : Cell a) -> RefT m a
  Write : (l : Cell a) -> (x : typeOf @{u} a) -> RefT m ()

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


{-

1. (String, String, String)
   List String
   ((Char, String), Char)

-}

{- 2 -}

palindrome : String -> Bool
palindrome str = str == reverse str

{- 3 -}

palindrome_q3 : String -> Bool
palindrome_q3 str = let strL = toLower str in
                        strL == reverse strL

{- 4 -}

palindrome_q4 : String -> Bool
palindrome_q4 str = if length str > 10
                       then palindrome_q3 str
                       else False

{- 5 -}

palindrome_q5 : Nat -> String -> Bool
palindrome_q5 min str = if length str > min
                           then palindrome_q3 str
                           else False

{- 6 -}

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

{- 7 -}

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

{- 8 -}

over_length : Nat -> List String -> Nat
over_length num xs = let lengths = map length xs in
                         length (filter (> num) lengths)


module Control.Algebra.Implementations

import Control.Algebra

-- This file is for algebra implementations with nowhere else to go.

%default total

-- Functions ---------------------------

Semigroup (ty -> ty) where
  (<+>) = (.)

SemigroupV (ty -> ty) where
  semigroupOpIsAssociative _ _ _ = Refl

Monoid (ty -> ty) where
  neutral = id

MonoidV (ty -> ty) where
  monoidNeutralIsNeutralL _ = Refl
  monoidNeutralIsNeutralR _ = Refl


module Data.Time.Clock.Internal.NominalDiffTime

import Data.Time.Clock.Internal.Fixed as F

public export
data NominalDiffTime = MkNominalDiffTime Pico

export
Enum NominalDiffTime where
  pred (MkNominalDiffTime x) = MkNominalDiffTime (pred x)
  toNat (MkNominalDiffTime x) = toNat x
  fromNat x = MkNominalDiffTime (fromNat x)

export
Show NominalDiffTime where
    show (MkNominalDiffTime t) = show t

export
Eq NominalDiffTime where
  (MkNominalDiffTime a) == (MkNominalDiffTime b) = a == b

export
Ord NominalDiffTime where
  compare (MkNominalDiffTime a) (MkNominalDiffTime b) = compare a b

add: NominalDiffTime -> NominalDiffTime -> NominalDiffTime
add (MkNominalDiffTime x) (MkNominalDiffTime y) = MkNominalDiffTime (x + y)

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

minus: NominalDiffTime -> NominalDiffTime -> NominalDiffTime
minus (MkNominalDiffTime x) (MkNominalDiffTime y) = MkNominalDiffTime (x - y)

negate: NominalDiffTime -> NominalDiffTime
negate (MkNominalDiffTime x) = MkNominalDiffTime (negate x)

abs : NominalDiffTime-> NominalDiffTime
abs (MkNominalDiffTime x) = MkNominalDiffTime (abs x)

fromInteger : Integer -> NominalDiffTime
fromInteger x = MkNominalDiffTime (MkFixed x)

mult: NominalDiffTime -> NominalDiffTime -> NominalDiffTime
mult (MkNominalDiffTime x) (MkNominalDiffTime y) = MkNominalDiffTime (x * y)

(*): NominalDiffTime -> NominalDiffTime -> NominalDiffTime
(*) = mult

toRational: NominalDiffTime -> Double
toRational (MkNominalDiffTime x) = (toRational x)

fracDiv: NominalDiffTime -> NominalDiffTime -> NominalDiffTime
fracDiv (MkNominalDiffTime x) (MkNominalDiffTime y) = MkNominalDiffTime (fracDiv x y)

(/): NominalDiffTime -> NominalDiffTime -> NominalDiffTime
(/) = fracDiv

recip : NominalDiffTime -> NominalDiffTime
recip (MkNominalDiffTime x) = MkNominalDiffTime (recip x)

secondsToNominalDiffTime: Integer -> NominalDiffTime
secondsToNominalDiffTime = fromInteger

picosecondsToNominalDiffTime: Integer -> NominalDiffTime
picosecondsToNominalDiffTime x = MkNominalDiffTime (MkFixed x)

diffTimeToPicoseconds : NominalDiffTime -> Integer
diffTimeToPicoseconds (MkNominalDiffTime (MkFixed x)) = x

-- | One day in 'NominalDiffTime'.
export
nominalDay: NominalDiffTime
nominalDay = 86400


import Lightyear.Combinators
import Lightyear.Core
import Lightyear.Char
import Lightyear.Strings

data Assoc = AssocNone
           | AssocLeft
           | AssocRight

data Operator a = Infix (Parser (a -> a -> a)) Assoc
                | Prefix (Parser (a -> a))
                | Postfix (Parser (a -> a))

LO : Type -> Type
LO a = List (Operator a)

OperatorTable : Type -> Type
OperatorTable a = List (LO a)

BinaryOperator : Type -> Type
BinaryOperator a = List (Parser (a -> a -> a))

UnaryOperator : Type -> Type
UnaryOperator a = List (Parser (a -> a))

data Ops a = BinOp (BinaryOperator a) | UnOp (UnaryOperator a)

ReturnType : Type -> Type
ReturnType a = (BinaryOperator a, BinaryOperator a, BinaryOperator a, UnaryOperator a, UnaryOperator a)

toParserBin : BinaryOperator a -> Parser (a -> a -> a)
toParserBin [] = fail "couldn't create binary parser"
toParserBin (x :: xs) = x <|> toParserBin xs

toParserUn : UnaryOperator a -> Parser (a -> a)
toParserUn [] = fail "couldn't create unary parser"
toParserUn (x :: xs) = x <|> toParserUn xs

ambigious : (assoc : String) -> (op : Parser (a -> a -> a)) -> Parser a
ambigious assoc op = do op
                        fail ("ambiguous use of a " ++ assoc ++ " associative operator")

mutual
  mkRassocP : (amLeft : Parser a) -> (amNon : Parser a) -> (rassocOp : Parser (a -> a -> a)) -> (termP : Parser a) -> (x : a) -> Parser a
  mkRassocP amLeft amNon rassocOp termP x =
   (do f <- rassocOp
       y <- do z <- termP ; mkRassocP1 amLeft amNon rassocOp termP z
       pure (f x y))
   <|> (amLeft)
   <|> (amNon)

  mkRassocP1 : (amLeft : Parser a) -> (amNon : Parser a) -> (rassocOp : Parser (a -> a -> a)) -> (termP : Parser a) -> (x : a) -> Parser a
  mkRassocP1 amLeft amNon rassocOp termP x = (mkRassocP amLeft amNon rassocOp termP x) <|> pure x

mutual
  mkLassocP : (amRight : Parser a) -> (amNon : Parser a) -> (lassocOp : Parser (a -> a -> a)) -> (termP : Parser a) -> (x : a) -> Parser a
  mkLassocP amRight amNon lassocOp termP x =
    (do f <- lassocOp
        y <- termP
        mkLassocP1 amRight amNon lassocOp termP (f x y))
    <|> amRight
    <|> amNon

  mkLassocP1 : (amRight : Parser a) -> (amNon : Parser a) -> (lassocOp : Parser (a -> a -> a)) -> (termP : Parser a) -> (x : a) -> Parser a
  mkLassocP1 amRight amNon lassocOp termP x = mkLassocP amRight amNon lassocOp termP x <|> pure x

mkNassocP : (amRight : Parser a) -> (amLeft : Parser a) -> (amNon : Parser a) -> (nassocOp : Parser (a -> a -> a)) -> (termP : Parser a) -> (x : a) -> Parser a
mkNassocP amRight amLeft amNon nassocOp termP x =
  do f <- nassocOp
     y <- termP
     amRight <|> amLeft <|> amNon
     pure (f x y)

buildExpressionParser : (a : Type) -> OperatorTable a -> Parser a -> Parser a
buildExpressionParser a operators simpleExpr =
  foldl (makeParser a) simpleExpr operators
  where
    splitOp : (a : Type) -> Operator a -> ReturnType a -> ReturnType a
    splitOp x (Infix op AssocNone) (rassoc, lassoc, nassoc, prefixx, postfix) = (rassoc, lassoc, op :: nassoc, prefixx, postfix)
    splitOp x (Infix op AssocLeft) (rassoc, lassoc, nassoc, prefixx, postfix) = (rassoc, op :: lassoc, nassoc, prefixx, postfix)
    splitOp x (Infix op AssocRight) (rassoc, lassoc, nassoc, prefixx, postfix) = (op :: rassoc, lassoc, nassoc, prefixx, postfix)
    splitOp x (Prefix op) (rassoc, lassoc, nassoc, prefixx, postfix) = (rassoc, lassoc, nassoc, op :: prefixx, postfix)
    splitOp x (Postfix op) (rassoc, lassoc, nassoc, prefixx, postfix) = (rassoc, lassoc, nassoc, prefixx, op :: postfix)

    makeParser : (a : Type) -> Parser a -> LO a -> Parser a
    makeParser a term ops =
      let (rassoc,lassoc,nassoc
               ,prefixx,postfix) = foldr (splitOp a) ([],[],[],[],[]) ops
          rassocOp = toParserBin rassoc
          lassocOp = toParserBin lassoc
          nassocOp = toParserBin nassoc
          prefixxOp = toParserUn prefixx
          postfixOp = toParserUn postfix

          amRight = ambigious "right" rassocOp
          amLeft = ambigious "left" lassocOp
          amNon = ambigious "non" nassocOp

          prefixxP = prefixxOp <|> pure id

          postfixP = postfixOp <|> pure id

          termP = do pre <- prefixxP
                     x <- term
                     post <- postfixP
                     pure (post (pre x))

          rassocP = mkRassocP amLeft amNon rassocOp termP
          rassocP1 = mkRassocP1 amLeft amNon rassocOp termP

          lassocP = mkLassocP amRight amNon lassocOp termP
          lassocP1 = mkLassocP1 amRight amNon lassocOp termP

          nassocP = mkNassocP amRight amLeft amNon nassocOp termP
          in
          do x <- termP
             rassocP x <|> lassocP  x <|> nassocP x <|> pure x <?> "operator"

mutual
  table : OperatorTable Integer
  table =
    [ [Infix (do token "*"; pure (*) ) AssocLeft]
    , [Infix (do token "+"; pure (+) ) AssocLeft]]

  intConst : Parser Integer
  intConst = do i <- integer
                pure (i)

  term : Parser Integer
  term = intConst <|>| parens expr
         <?> "simple expression"

  expr : Parser Integer
  expr = buildExpressionParser Integer table term


module Sub04Apply54x48

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqPostuProof

%default total
-- %language ElabReflection

-- 3(18x+16) --A[6,-4]->B[1,-2]--> 3(4x+3)
export
apply54x48 : (Not . P) (S (S (S (S (plus (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))
                                  (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                            (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))))))
  -> (m : Nat **
        (LTE (S m)
             (S (S (S (S (plus (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l)))) (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                               (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l)))))))))))),
         (Not . P) m))
apply54x48 {l} col = ((S (S (S (plus (plus l l) (plus l l))))) ** (lte54x48 l, ab54x30To12x9 l col)) where
  lte54x48 : (l:Nat) -> LTE (S (S (S (S (plus (plus l l) (plus l l))))))
                            (S (S (S (S (plus (plus (plus (plus (plus l l) l) (S (S (plus (plus l l) l)))) (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))
                                              (S (S (S (plus (plus (plus l l) l) (S (S (plus (plus l l) l))))))))))))
  lte54x48 Z = (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
  lte54x48 (S k) = let lemma = lte54x48 k in
    rewrite (sym (plusSuccRightSucc k k)) in
    rewrite (sym (plusSuccRightSucc (plus k k) (S (plus k k)))) in
    rewrite (sym (plusSuccRightSucc (plus k k) (plus k k))) in
    rewrite (sym (plusSuccRightSucc (plus k k) k)) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) k) (S (S (S (S (plus (plus k k) k))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) k) (S (S (S (plus (plus k k) k)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) k) (S (S (plus (plus k k) k))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))  (S (S (S (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))  (S (S (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))  (S (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))  (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))  (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))  (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))) (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))  (S (S (S (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))) (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))  (S (S (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))) (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))  (S (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))) (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))  (S (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))) (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))  (S (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (S (plus (plus k k) k)))) (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))  (S (S (S (plus (plus (plus k k) k) (S (S (plus (plus k k) k))))))))) in
      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc) lemma


module Main

%default total

data U : Type where
  BOOL : U
  NAT : U
  PAIR : U -> U -> U

interpU : U -> Type
interpU BOOL = Bool
interpU NAT = Nat
interpU (PAIR x y) = (interpU x, interpU y)

showU : (u : U) -> interpU u -> String
showU BOOL True            = "Yes"
showU BOOL False           = "No"
showU NAT Z                = "Z"
showU NAT (S x)            = "S of " ++ showU NAT x
showU (PAIR tx ty) (x , y) = "(" ++ showU tx x ++ "," ++ showU ty y ++ ")"

main : IO ()
main = putStrLn $ showU NAT 0


-- ---------------------------------------------------------------- [ Main.idr ]
-- Module      : Main
-- Description : Test runner for solutions to exercises in Edwin Brady's
--               book, "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]

module Main

import Exercises.Test.GettingStarted
import Exercises.Test.Interactive
import Exercises.Test.DataTypes
import Exercises.Test.State

import Test.Helpers
import Test.Utils

import Data.Vect
import System

main : IO ()
main = do resCh2  <- GettingStarted.runTests
          resCh3  <- Interactive.runTests
          resCh4  <- DataTypes.runTests
          resCh12 <- State.runTests
          let results = resCh2 ++ resCh3 ++ resCh4 ++ resCh12
          printSummary results
          when (any not results) (exit 1)

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


module Control.Optics.Either

import public Control.Optics.Prism

export
pleft : Prism (Either a c) (Either b c) a b
pleft = prism Left (either Right (Left . Right))


||| A collection of utlities shared accross the Razors.
|||
||| This consists of:
|||
|||  + some syntactic sugar to make functions detailing renaming,
|||    weakening, and substitution more like those seen in PLFA.
|||
|||  + Some data structures to make working with collections of
|||    dependent types easier.
module Razor.Common

import public Decidable.Equality

import public Data.List.Elem
import public Data.Vect
import public Data.Vect.Elem
import public Data.Fin
import public Data.DPair

%default total

-- A reverse cons operator.
infixr 6 +=

namespace List

  ||| Proof that the given list (`xs`) contains the given element
  ||| (`x`).
  |||
  |||
  public export
  Contains : List a -> a -> Type
  Contains xs x = Elem x xs

  ||| Append `x` to the head of `xs`.
  public export
  (+=) : List a -> a -> List a
  (+=) xs x = x :: xs

namespace Vect

  ||| Append `x` to the head of `xs`.
  public export
  (+=) : (xs : Vect n a) -> (x : a) -> Vect (S n) a
  (+=) xs x = x :: xs

namespace DList

  ||| A list construct for dependent types.
  |||
  ||| @a  The type of the value contained within the list element type.
  ||| @e  The type of the elements within the list
  ||| @vs The List used to contain the different values within the type.
  public export
  data DList : (a : Type)
            -> (e : a -> Type)
            -> (vs : List a)
            -> Type
    where
      Nil  : DList a e Nil
      (::) : forall v
           .  (head : (e v))
           -> (tail : DList a e vs)
                   -> DList a e (v::vs)

  ||| Append `x` to the head of `xs`.
  public export
  (+=) : forall v
       . (xs : DList a e vs)
      -> (x  : e v)
            -> DList a e (v::vs)
  (+=) xs x = x :: xs

  ||| A proof that some element (`x`) is found in the given list (`xs`).
  public export
  data Elem : (a : Type)
           -> (e : a -> Type)
           -> forall i, is
            . (x      : e i)
           -> (xs     : DList a e is)
           -> Type
      where
        ||| The element is at the head of the list.
        Here : Elem a e x (x :: xs)

        ||| The element is found in the tail of the list.
        There : (rest : Elem a e x        xs)
                     -> Elem a e x (x' :: xs)

namespace Index
  public export
  data AtIndex : (idx : Fin n)
              -> (xs  : Vect n type)
              -> (x   : type)
                     -> Type
    where
      Here : AtIndex FZ (x::xs) x

      There : (later : AtIndex     rest      xs  x)
                    -> AtIndex (FS rest) (y::xs) x

  namespace Check
    public export
    elemDiffers : (y = x -> Void)
                -> AtIndex FZ (y :: xs) x
                -> Void
    elemDiffers f Here
      = f Refl

    public export
    elemNotInRest : (AtIndex z xs x -> Void)
                 ->  AtIndex (FS z) (y :: xs) x
                 ->  Void
    elemNotInRest f (There later)
      = f later

    ||| Is the element at the given index?
    |||
    public export
    index : DecEq type
         => (idx : Fin n)
         -> (x   : type)
         -> (xs  : Vect n type)
                -> Dec (AtIndex idx xs x)

    index FZ _ [] impossible
    index (FS y) _ [] impossible

    index FZ x (y :: xs) with (decEq y x)
      index FZ x (x :: xs) | (Yes Refl)
        = Yes Here
      index FZ x (y :: xs) | (No contra)
        = No (elemDiffers contra)

    index (FS z) x (y :: xs) with (Check.index z x xs)
      index (FS z) x (y :: xs) | (Yes prf)
        = Yes (There prf)
      index (FS z) x (y :: xs) | (No contra)
        = No (elemNotInRest contra)

  namespace Find
    public export
    elemNotInRest : (DPair type (AtIndex     x        xs)  -> Void)
                 ->  DPair type (AtIndex (FS x) (y :: xs)) -> Void

    elemNotInRest f (MkDPair i (There later))
      = f (MkDPair i later)

    ||| What is the element at the given index?
    |||
    public export
    index : DecEq type
         => (idx : Fin n)
         -> (xs  : Vect n type)
                -> Dec (DPair type (AtIndex idx xs))
    index FZ (x :: xs)
      = Yes (MkDPair x Here)

    index (FS x) (y :: xs) with (Find.index x xs)
      index (FS x) (y :: xs) | (Yes (MkDPair i idx))
        = Yes (MkDPair i (There idx))
      index (FS x) (y :: xs) | (No contra) = No (elemNotInRest contra)

-- [ EOF ]


module Main

import Interp
import Ast
import Examples
import Data.List

%default partial

nil : Term
nil = Comp "nil" []

cons : Term -> Term -> Term
cons head tail = Comp "cons" [head, tail]

append : Term -> Term -> Term -> Term
append xs ys res = Comp "append" [xs, ys, res]

Xs : Term
Xs = Var "Xs"

Y : Term
Y = Var "Y"

Ys : Term
Ys = Var "Ys"

Rec : Term
Rec = Var "Rec"

program2 : Program
program2 = unDSL
  [ append nil Ys Ys
  , append (cons X Xs) Ys (cons X Rec) :- [append Xs Ys Rec]
  ]

-- Some tests
main : IO ()
main = do
  putStrLn "\n--------------- append empty right"
  print $ (nub $ bfs $ makeReportTree program2 [append (cons X nil) nil Rec])
  putStrLn "\n--------------- append empty left"
  print $ (nub $ bfs $ makeReportTree program2 [append nil Xs Rec])
  putStrLn "\n--------------- append example"
  printLn $ (nub $ bfs $ makeReportTree program2 [append (cons X nil) (cons Y (cons p nil)) Rec])


import Data.List.Views

-- total
isSuffix : Eq a => List a -> List a -> Bool
isSuffix input1 input2 with (snocList input1, snocList input2)
  isSuffix _ _ | (Snoc x xs xsrec, Snoc y ys ysrec)
     = (x == y) && (isSuffix _ _ | (xsrec, ysrec))
  isSuffix _ _ | (Empty, s) = True
  isSuffix _ _ | (s, Empty) = False


module Stream.Util

import Data.Colist
import Data.SnocList
import Data.Vect
import Stream.Internal

public export
data Of : (v,r : Type) -> Type where
  MkOf : (val : v) -> Of v ()

public export
fromOf : Of a b -> a
fromOf (MkOf val) = val

--------------------------------------------------------------------------------
--          Producers
--------------------------------------------------------------------------------

export %inline
yield : a -> Stream (Of a) m ()
yield = yields . MkOf

export
list : List a -> Stream (Of a) m ()
list []        = pure ()
list (x :: xs) = yield x >> list xs

export
stream : Stream a -> Stream (Of a) m Void
stream (x :: y) = yield x >> stream y

export
colist : Colist a -> Stream (Of a) m ()
colist []       = pure ()
colist (x :: y) = yield x >> colist y

||| Generates the sequence (ini, f ini, f $ f ini, ...)
export
iterate : (fun : a -> a) -> (ini : a) -> Stream (Of a) m Void
iterate f ini = yield ini >> iterate f (f ini)

export
generate : (s -> (s,a)) -> s -> Stream (Of a) m Void
generate f ini = let (vs,va) = f ini in yield va >> generate f vs

export
tillRight : m (Either a r) -> Stream (Of a) m r
tillRight x = lift x >>= next
  where next : Either a r -> Stream (Of a) m r
        next (Left v)  = yield v >> tillRight x
        next (Right r) = pure r

--------------------------------------------------------------------------------
--          Consuming Streams
--------------------------------------------------------------------------------

export
mapM_ : (a -> m x) -> Stream (Of a) m r -> Stream Empty m r
mapM_ f y = case toView y of
  BindP val      w => pure val >>= \v => mapM_ f (w v)
  BindF (MkOf v) w => lift (f v) >>= \_ => mapM_ f (w ())
  BindM act      w => lift act >>= \v => mapM_ f (w v)
  VP val           => pure val
  VF (MkOf v)      => ignore $ lift (f v)
  VM act           => lift act

export %inline
effects : Applicative m => Stream (Of a) m r -> Stream Empty m r
effects = mapM_ (const $ pure ())

--------------------------------------------------------------------------------
--          Folds
--------------------------------------------------------------------------------

export
fold :  (x -> a -> x)
     -> x
     -> (x -> b)
     -> Stream (Of a) m r
     -> Stream Empty m (b,r)
fold step ini done x = case toView x of
  BindP val      z => pure val >>= \v => fold step ini done (z v)
  BindF (MkOf v) z => pure () >> fold step (step ini v) done (z ())
  BindM act      z => lift act >>= \v => fold step ini done (z v)
  VP val           => pure (done ini, val)
  VF (MkOf v)      => pure (done $ step ini v, ())
  VM act           => (done ini,) <$> lift act

export %inline
fold_ :  (x -> a -> x)
      -> x
      -> (x -> b)
      -> Stream (Of a) m r
      -> Stream Empty m b
fold_ step ini done = map fst . fold step ini done

export %inline
foldMap : Monoid mo => (a -> mo) -> Stream (Of a) m r -> Stream Empty m (mo,r)
foldMap f = fold (\vmo,va => vmo <+> f va) neutral id

export %inline
foldMap_ : Monoid mo => (a -> mo) -> Stream (Of a) m r -> Stream Empty m mo
foldMap_ f = map fst . foldMap f

export %inline
sum : Num a => Stream (Of a) m r -> Stream Empty m (a,r)
sum = fold (+) 0 id

export %inline
sum_ : Num a => Stream (Of a) m r -> Stream Empty m a
sum_ = map fst . sum

export %inline
product : Num a => Stream (Of a) m r -> Stream Empty m (a,r)
product = fold (*) 0 id

export %inline
product_ : Num a => Stream (Of a) m r -> Stream Empty m a
product_ = map fst . product

export %inline
length : Stream (Of a) m r -> Stream Empty m (Nat,r)
length = fold (\x,_ => S x) 0 id

export %inline
length_ : Stream (Of a) m r -> Stream Empty m Nat
length_ = map fst . length

export %inline
count : (a -> Bool) -> Stream (Of a) m r -> Stream Empty m (Nat,r)
count p = fold (\x,va => if p va then S x else x) 0 id

export %inline
count_ : (a -> Bool) -> Stream (Of a) m r -> Stream Empty m Nat
count_ p = map fst . count p

export %inline
first : Stream (Of a) m r -> Stream Empty m (Maybe a,r)
first = fold (\acc,va => acc <|> Just va) Nothing id

export %inline
first_ : Stream (Of a) m r -> Stream Empty m (Maybe a)
first_ = map fst . first

export %inline
last : Stream (Of a) m r -> Stream Empty m (Maybe a,r)
last = fold (\_,va => Just va) Nothing id

export %inline
last_ : Stream (Of a) m r -> Stream Empty m (Maybe a)
last_ = map fst . last

export %inline
minimum : Ord a => Stream (Of a) m r -> Stream Empty m (Maybe a,r)
minimum = fold (\acc,va => map (min va) acc <|> Just va) Nothing id

export %inline
minimum_ : Ord a => Stream (Of a) m r -> Stream Empty m (Maybe a)
minimum_ = map fst . minimum

export %inline
maximum : Ord a => Stream (Of a) m r -> Stream Empty m (Maybe a,r)
maximum = fold (\acc,va => map (max va) acc <|> Just va) Nothing id

export %inline
maximum_ : Ord a => Stream (Of a) m r -> Stream Empty m (Maybe a)
maximum_ = map fst . maximum

export %inline
all : (a -> Bool) -> Stream (Of a) m r -> Stream Empty m (Bool,r)
all p = fold (\acc,va => acc && p va) True id

export %inline
all_ : (a -> Bool) -> Stream (Of a) m r -> Stream Empty m Bool
all_ p = map fst . all p

export %inline
any : (a -> Bool) -> Stream (Of a) m r -> Stream Empty m (Bool,r)
any p = fold (\acc,va => acc || p va) False id

export %inline
any_ : (a -> Bool) -> Stream (Of a) m r -> Stream Empty m Bool
any_ p = map fst . any p

export %inline
elem : Eq a => a -> Stream (Of a) m r -> Stream Empty m (Bool, r)
elem va = any (va ==)

export %inline
elem_ : Eq a => a -> Stream (Of a) m r -> Stream Empty m Bool
elem_ va = map fst . elem va

export %inline
toSnocList : Stream (Of a) m r -> Stream Empty m (SnocList a, r)
toSnocList = fold (:<) Lin id

export %inline
toSnocList_ : Stream (Of a) m r -> Stream Empty m (SnocList a)
toSnocList_ = map fst . toSnocList

export %inline
toList : Stream (Of a) m r -> Stream Empty m (List a, r)
toList = map (\(sx,vr) => (sx <>> Nil, vr)) . toSnocList

export %inline
toList_ : Stream (Of a) m r -> Stream Empty m (List a)
toList_ = map fst . toList

export
foldM :  (x -> a -> m x)
      -> m x
      -> (x -> m b)
      -> Stream (Of a) m r
      -> Stream Empty m (b,r)
foldM step ini done x = case toView x of
  BindF (MkOf v) z => do
    vx <- lift ini
    foldM step (step vx v) done (z ())

  BindP val      z => pure val >>= \v => foldM step ini done (z v)
  BindM act      z => lift act >>= \v => foldM step ini done (z v)

  VP val        => do
    vx <- lift ini
    vb <- lift (done vx)
    pure (vb, val)

  VF (MkOf v)   => do
    vx  <- lift ini
    vx2 <- lift (step vx v)
    vb  <- lift (done vx2)
    pure (vb,())

  VM act        => do
    vr <- lift act
    vx <- lift ini
    vb <- lift (done vx)
    pure (vb, vr)

export
scan :  (x -> a -> x)
     -> x
     -> (x -> b)
     -> Stream (Of a) m r
     -> Stream (Of b) m r
scan step ini done str = yield (done ini) >>= \_ => go ini str
  where go : x -> Stream (Of a) m r -> Stream (Of b) m r
        go vx s = case toView s of
          BindF (MkOf v) z =>
            let vx2 = step vx v
             in yield (done vx2) >> go vx2 (z ())
          BindP val      z => pure val >>= \v => go vx (z v)
          BindM act      z => lift act >>= \v => go vx (z v)
          VP val           => pure val
          VF (MkOf v)      => yield (done $ step vx v)
          VM act           => lift act

--------------------------------------------------------------------------------
--          Filters and Stream Transformers
--------------------------------------------------------------------------------

export
for : Stream (Of a) m r -> (a -> Stream f m x) -> Stream f m r
for str fun = case toView str of
  BindF (MkOf va) z => fun va   >>= \_ => for (z ()) fun
  BindP val       z => pure val >>= \v => for (z v) fun
  BindM act       z => lift act >>= \v => for (z v) fun
  VF (MkOf va)      => ignore $ fun va
  VP val            => pure val
  VM act            => lift act

export
mapVals : (a -> b) -> Stream (Of a) m r -> Stream (Of b) m r
mapVals f str = for str (yield . f)

export %inline
castVals : Cast from to => Stream (Of from) m r -> Stream (Of to) m r
castVals = mapVals cast

export
mapValsM : (a -> m b) -> Stream (Of a) m r -> Stream (Of b) m r
mapValsM f str = for str $ \va => lift (f va) >>= yield

export
drain : Stream (Of a) m r -> Stream (Of a) m r
drain str = for str (\_ => pure ())

export %inline
with_ : Stream (Of a) m r -> (a -> f x) -> Stream f m r
with_ str fun = for str (yields . fun)

export %inline
subst : (a -> f x) -> Stream (Of a) m r -> Stream f m r
subst fun str = for str (yields . fun)

export
filter : (a -> Bool) -> Stream (Of a) m r -> Stream (Of a) m r
filter p x = case toView x of
  BindF (MkOf val) z =>
    if p val
       then yield val >> filter p (z ())
       else pure ()   >> filter p (z ())
  BindP val z    => pure val >>= \v => filter p (z v)
  BindM act z    => lift act >>= \v => filter p (z v)
  VP val         => pure val
  VF (MkOf v)    => if p v then yield v else pure ()
  VM act         => lift act

export
mapMaybe : (a -> Maybe b) -> Stream (Of a) m r -> Stream (Of b) m r
mapMaybe f x = case toView x of
  BindF (MkOf val) z => case f val of
    Just vb => yield vb >> mapMaybe f (z ())
    Nothing => pure ()  >> mapMaybe f (z ())
  BindP val z    => pure val >>= \v => mapMaybe f (z v)
  BindM act z    => lift act >>= \v => mapMaybe f (z v)
  VF (MkOf v)    => case f v of
    Just vb => yield vb
    Nothing => pure ()
  VP val         => pure val
  VM act         => lift act

export
span :  (a -> Bool)
     -> Stream (Of a) m r
     -> Stream (Of a) m (Stream (Of a) m r)
span p x = case toView x of
  BindF (MkOf val) z =>
    if p val
       then pure (yield val >> z ())
       else yield val >> span p (z ())
  BindP val z => pure val >>= \v => span p (z v)
  BindM act z => lift act >>= \v => span p (z v)
  VP val      => pure (pure val)
  VF (MkOf v) => if p v then pure (yield v) else yield v >> (pure $ pure ())
  VM act      => pure $ lift act

export %inline
takeUntil : (a -> Bool) -> Stream (Of a) m r -> Stream (Of a) m ()
takeUntil p = ignore . span p

export %inline
takeWhile : (a -> Bool) -> Stream (Of a) m r -> Stream (Of a) m ()
takeWhile p = takeUntil (not . p)

export
dropUntil : (a -> Bool) -> Stream (Of a) m r -> Stream (Of a) m r
dropUntil p str = drain (span p str) >>= id

export
dropWhile : (a -> Bool) -> Stream (Of a) m r -> Stream (Of a) m r
dropWhile p = dropUntil (not . p)

export
drop : Nat -> Stream (Of a) m r -> Stream (Of a) m r
drop n str = drain (splitsAt n str) >>= id

export
slidingWindow :  (n : Nat)
              -> {auto 0 prf : IsSucc n}
              -> Stream (Of a) m r
              -> Stream (Of $ Vect n a) m r
slidingWindow (S k) =
  mapMaybe sequence .
  scan (\prev,va => Just va :: init prev) (replicate (S k) Nothing) id

export
breakWith :  (a -> Maybe (a,a))
          -> Stream (Of a) m r
          -> Stream (Of a) m (Stream (Of a) m r)
breakWith f x = case toView x of
  BindF (MkOf y) g => case f y of
    Just (yh,yt) => yield yh >>= \v => pure (yield yt >>= \_ => g v)
    Nothing      => yield y >>= \v => breakWith f (g v)
  BindP y g => pure y >>= \v => breakWith f (g v)
  BindM y g => lift y >>= \v => breakWith f (g v)
  VF (MkOf y) => case f y of
    Just (yh,yt) => yield yh >> pure (yield yt)
    Nothing      => yield y  >> pure (pure ())
  VP y => pure (pure y)
  VM y => pure (lift y)

export
splitWith :  (a -> Maybe (a,a))
          -> Stream (Of a) m r
          -> Stream (Stream (Of a) m) m r
splitWith f s = F (breakWith f s) >>=
  \case P r => P r
        M y => M y
        x   => splitWith f x


module lib.test.LibTest

import lib.Library
import System
import idristest.Suite

testDouble : (Bool, String)
testDouble = assertEq "Test double" (2 * 2) 4

testTriple : (Bool, String)
testTriple = assertNotEq "Test triple" (2 * 2 * 2) 5

testLibrary1 : (Bool, String)
testLibrary1 = assertEq "Test salute" salute "Hello, library example of idris"

testLibrary2 : (Bool, String)
testLibrary2 = assertNotEq "Test salute diff" salute "Ups"

export
test : IO Bool
test = runTests [testDouble, testTriple, testLibrary1, testLibrary2]


module SlideWise

import Data.Vect

public export data SlideWise2: Vect (S (S n)) e -> (Vect 2 e -> Type) -> Type where
  HeadMatches2: (searched: Vect (S (S m)) e) -> (match: Vect 2 e) -> (rest:Vect m e) -> prf match  -> SlideWise2 (match++rest) prf
  RestMatches2: (x:e) -> (rest: Vect (S (S n)) e) -> SlideWise2 rest prf -> SlideWise2 (x::rest) prf

export getMatchAndRest2: (xs: Vect (S (S n)) e) -> (prf: SlideWise2 xs prfT) -> (Vect 2 e, Vect n e)
getMatchAndRest2 (match ++ rest) (HeadMatches2 searched match rest x) = (match, rest)
getMatchAndRest2 (x :: rest) (RestMatches2 x rest prf) = let (match, rest') = getMatchAndRest2 rest prf in
                                                                 (match, x::rest')

export getRest2: (xs: Vect (S (S n)) e) -> (prf: SlideWise2 xs prfT) -> Vect n e
getRest2 (match ++ rest) (HeadMatches2 searched match rest x) = rest
getRest2 (x :: rest) (RestMatches2 x rest prf) = x::(getRest2 rest prf)

export getMatch2: (xs: Vect (S (S n)) e) -> (prf: SlideWise2 xs prfT) -> Vect 2 e
getMatch2 (match ++ rest) (HeadMatches2 searched match rest x) = match
getMatch2 (x :: rest) (RestMatches2 x rest prf) = getMatch2 rest prf

reachedEnd2 : (contra : prfT ([x1, x2]) -> Void) -> SlideWise2 [x1, x2] prfT -> Void
reachedEnd2 contra (HeadMatches2 sorted (x1:: x2 :: []) [] prf) = contra prf

notInHeadOrRest2 : (contra : SlideWise2 (x2 :: (x3 :: xs)) prfT -> Void) -> (head_contra : prfT [x1, x2] -> Void) -> SlideWise2 (x1 :: (x2 :: (x3 :: xs))) prfT -> Void
notInHeadOrRest2 contra head_contra (RestMatches2 x1 (x2 :: (x3 :: xs)) x) = contra x

export isSlideWise2: (xs: Vect (S (S n)) e) -> (prfFun: (y:Vect 2 e) -> Dec (prfT y)) -> Dec (SlideWise2 xs prfT)
isSlideWise2 {n = Z} (x1 :: x2:: []) prfFun = case prfFun [x1, x2] of
                                                (Yes prf) => Yes (HeadMatches2 [x1, x2] [x1, x2] [] prf)
                                                (No contra) => No (reachedEnd2 contra)
isSlideWise2 {n = (S k)} (x1 :: x2 :: x3 :: xs) prfFun = case prfFun [x1, x2] of
                                                              (Yes prf) => Yes (HeadMatches2 (x1 :: x2 :: x3 :: xs) [x1, x2] (x3::xs) prf)
                                                              (No head_contra) => (case isSlideWise2 (x2::x3::xs) prfFun of
                                                                                (Yes prf) => Yes (RestMatches2 x1 (x2::x3::xs) prf)
                                                                                (No contra) => No (notInHeadOrRest2 contra head_contra))

public export data SlideWise3: Vect (S (S (S n))) e -> (Vect 3 e -> Type) -> Type where
 HeadMatches3: (searched: Vect (S (S (S m))) e) -> (match: Vect 3 e) -> (rest:Vect m e) -> prf match  -> SlideWise3 (match++rest) prf
 RestMatches3: (x:e) -> (rest: Vect (S (S (S n))) e) -> SlideWise3 rest prf -> SlideWise3 (x::rest) prf

export getMatchAndRest3:(xs: Vect (S (S (S n))) e) -> (prf: SlideWise3 xs prfT) -> (Vect 3 e, Vect n e)
getMatchAndRest3 (match ++ rest) (HeadMatches3 searched match rest x) = (match, rest)
getMatchAndRest3 (x :: rest) (RestMatches3 x rest prf) = let (match, rest') = getMatchAndRest3 rest prf in
                                                                (match, x::rest')

export getRest3: (xs: Vect (S (S (S n))) e) -> (prf: SlideWise3 xs prfT) -> Vect n e
getRest3 (match ++ rest) (HeadMatches3 searched match rest x) = rest
getRest3 (x :: rest) (RestMatches3 x rest prf) = let rest' = getRest3 rest prf in
                                                                x::rest'

export getMatch3:(xs: Vect (S (S (S n))) e) -> (prf: SlideWise3 xs prfT) -> Vect 3 e
getMatch3 (match ++ rest) (HeadMatches3 searched match rest x) = match
getMatch3 (x :: rest) (RestMatches3 x rest prf) = let match = getMatch3 rest prf in
                                                            match

reachedEnd3 : (contra : prfT [x1, x2, x3] -> Void) -> SlideWise3 [x1, x2, x3] prfT -> Void
reachedEnd3 contra (HeadMatches3 sorted (x1:: x2 :: x3 :: []) [] prf) = contra prf

notInHeadOrRest3 : (contra : SlideWise3 (x2 :: (x3 :: (x4 :: xs))) prfT -> Void) -> (head_contra : prfT [x1, x2, x3] -> Void) -> SlideWise3 (x1 :: (x2 :: (x3 :: (x4 :: xs)))) prfT -> Void
notInHeadOrRest3 contra head_contra (RestMatches3 x1 (x2 :: (x3 :: (x4 :: xs))) x) = contra x

export isSlideWise3: (xs: Vect (S (S (S n))) e) -> (prfFun: (y:Vect 3 e) -> Dec (prfT y)) -> Dec (SlideWise3 xs prfT)
isSlideWise3 {n = Z} (x1::x2::x3::[]) prfFun = case prfFun [x1, x2, x3] of
                                                    (Yes prf) => Yes (HeadMatches3 [x1, x2, x3] [x1, x2, x3] [] prf)
                                                    (No contra) => No (reachedEnd3 contra)
isSlideWise3 {n = (S k)} (x1::x2::x3::x4::xs) prfFun = case prfFun [x1, x2, x3] of
                                          (Yes prf) => Yes (HeadMatches3 (x1::x2::x3::x4::xs) [x1, x2, x3] (x4::xs) prf)
                                          (No head_contra) => (case isSlideWise3 (x2::x3::x4::xs) prfFun of
                                                               (Yes prf) => Yes (RestMatches3 x1 (x2::x3::x4::xs) prf)
                                                               (No contra) => No (notInHeadOrRest3 contra head_contra))

public export data SlideWise4: Vect (S (S (S (S n)))) e -> (Vect 4 e -> Type) -> Type where
  HeadMatches4: (searched: Vect (S (S (S (S m)))) e) -> (match: Vect 4 e) -> (rest:Vect m e) -> prf match  -> SlideWise4 (match++rest) prf
  RestMatches4: (x:e) -> (rest: Vect (S (S (S (S n)))) e) -> SlideWise4 rest prf -> SlideWise4 (x::rest) prf

export getMatchAndRest4:(xs: Vect (S (S (S (S n)))) e) -> (prf: SlideWise4 xs prfT) -> (Vect 4 e, Vect n e)
getMatchAndRest4 (match ++ rest) (HeadMatches4 searched match rest x) = (match, rest)
getMatchAndRest4 (x :: rest) (RestMatches4 x rest prf) = let (match, rest') = getMatchAndRest4 rest prf in
                                                               (match, x::rest')

reachedEnd4 : (contra : prfT (x1::x2::x3::x4::[]) -> Void) -> SlideWise4 (x1::x2::x3::x4::[]) prfT -> Void
reachedEnd4 contra (HeadMatches4 sorted (x1::x2::x3::x4::[]) [] prf) = contra prf

notInHeadOrRest4 : (contra : SlideWise4 (x2 :: (x3 :: (x4 :: (x5 :: xs)))) prfT -> Void) -> (head_contra : prfT [x1, x2, x3, x4] -> Void) -> SlideWise4 (x1 :: (x2 :: (x3 :: (x4 :: (x5 :: xs))))) prfT -> Void
notInHeadOrRest4 contra head_contra (RestMatches4 x1 (x2 :: (x3 :: (x4 :: (x5 :: xs)))) x) = contra x

export isSlideWise4: (xs: Vect (S (S (S (S n)))) e) -> (prfFun: (y:Vect 4 e) -> Dec (prfT y)) -> Dec (SlideWise4 xs prfT)
isSlideWise4 {n = Z} (x1::x2::x3::x4::[]) prfFun = case prfFun [x1, x2, x3, x4] of
                                                   (Yes prf) => Yes (HeadMatches4 [x1, x2, x3, x4] [x1, x2, x3, x4] [] prf)
                                                   (No contra) => No (reachedEnd4 contra)
isSlideWise4 {n = (S k)} (x1::x2::x3::x4::x5::xs) prfFun = case prfFun [x1, x2, x3, x4] of
                                         (Yes prf) => Yes (HeadMatches4 (x1::x2::x3::x4::x5::xs) [x1, x2, x3, x4] (x5::xs) prf)
                                         (No head_contra) => (case isSlideWise4 (x2::x3::x4::x5::xs) prfFun of
                                                              (Yes prf) => Yes (RestMatches4 x1 (x2::x3::x4::x5::xs) prf)
                                                              (No contra) => No (notInHeadOrRest4 contra head_contra))


module UnboundImplsWhere

import Data.Vect

xs : Nat
xs = 5

-- Having `xs` above gives us a warning as if `xs` in `x` is a parameter.
-- Turning off unbound implicits in the `where` block moves warning away, but leaves implicits to be turned off after where block.

g : Vect n a -> Nat
g xs = x $ lengthCorrect xs where

--  %unbound_implicits off

  x : length xs = n -> Nat
  x _ = 5

f : List a -> Nat


module Verpackung.IOEither

public export
data IOEither a b
 = MkIOEither (IO (Either a b))

export
Functor (IOEither a) where
  map func (MkIOEither x) = MkIOEither (map (map func) x)

||| Lift a two-argument function to an applicative
export
liftA2 : Applicative f => (a -> b -> c) -> f a -> f b -> f c
liftA2 f a b = (map f a) <*> b

export
Applicative (IOEither a) where
  pure x = MkIOEither (pure (pure x))
  (<*>) (MkIOEither x) (MkIOEither y) = MkIOEither (liftA2 (<*>) x y)

export
Monad (IOEither a) where
  (>>=) (MkIOEither x) f = MkIOEither (do x' <- x
                                          (case x' of
                                                (Left l) => pure (Left l)
                                                (Right r) => let MkIOEither g = f r in
                                                                 g))
  join x = x >>= id

export
liftEither : Either e a -> IOEither e a
liftEither = MkIOEither . pure

export
liftIO : IO a -> IOEither e a
liftIO x = MkIOEither $ do
  x' <- x
  pure $ pure x'

export
liftIOEither : IOEither e a -> IO (Either e a)
liftIOEither (MkIOEither x) = x

export
mapErr : (e -> e') -> IOEither e a -> IOEither e' a
mapErr f (MkIOEither x) = MkIOEither (do
  x' <- x
  case x' of
        (Left l) => pure (Left (f l))
        (Right r) => pure (Right r))


import DataStore

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

showItems : DataStore schema -> List (SchemaType schema)
showItems input with (storeView input)
  showItems input | SNil = []
  showItems (addToStore value store) | (SAdd rec)
    = value :: showItems store | rec

filterKeys : (test : SchemaType val_schema -> Bool) ->
             DataStore (SString .+. val_schema) -> List String
filterKeys test input with (storeView input)
  filterKeys test input | SNil = []
  filterKeys test (addToStore (key, value) store) | (SAdd rec)
    = if test value
      then key :: filterKeys test store | rec
      else filterKeys test store | rec

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


import Data.Vect

parameters (len : Nat)
  record Foo where
    constructor Bar
    Gnat : Vect len Nat

foo : Foo 1
foo = Bar _ [0]