module ZipFolds

-- Based on http://okmij.org/ftp/Haskell/zip-folds.lhs

data FR : (a : Type) -> Type where
  Cont : ({r : Type} -> (a -> r -> r) -> r -> r) -> FR a

ofList : List a -> FR a
ofList l = Cont (\f, r => foldr f r l)

toList : FR a -> List a
toList (Cont f) = f (::) []

map : (a -> b) -> FR a -> FR b
map f (Cont g) = Cont (\h => g (\x, r => h (f x) r))

filter : (a -> Bool) -> FR a -> FR a
filter f (Cont g) = Cont (\h => g (\x, r => if f x then h x r else r))

drop : Int -> FR a -> FR a
drop n (Cont f) = Cont (\g, z => let f' = f (acc g) (seed z) in f' n)
  where
    acc : (a -> r -> r) -> a -> (Int -> r) -> Int -> r
    acc f x r n = if n <= 0 then f x (r n) else r (n - 1)
    seed : r -> Int -> r
    seed x _ = x

zipWith : (a -> b -> c) -> FR a -> FR b -> FR c
zipWith t (Cont f) fr = Cont (\g, z => let f' = f (acc z g) (seed z) in f' fr)
  where
    acc : r -> (c -> r -> r) -> a -> (FR b -> r) -> FR b -> r
    acc z f x r (Cont r2) = r2 (\y, _ => f (t x y) (r (drop 1 (Cont r2)))) z
    seed : r -> FR b -> r
    seed x _ = x

stream : FR Int
stream = ofList [1..10]

test : List (Int, Int)
test = toList $ zipWith (\x, y => (x, y)) stream stream


-- examples in "Type-Driven Development with Idris"
-- chapter 15, section 15.2

import System.Concurrency.Channels

-- check that all functions are total
%default total

data Message = Add Nat Nat

data MessagePID = MkMessage PID

data Process : Type -> Type where
  Action : IO a -> Process a
  Pure : a -> Process a
  (>>=) : Process a -> (a -> Process b) -> Process b
  Spawn : Process () -> Process (Maybe MessagePID)
  Request : MessagePID -> Message -> Process (Maybe Nat)
  Respond : ((msg : Message) -> Process Nat) -> Process (Maybe Message)
  Loop : Inf (Process a) -> Process a

partial
run : Process t -> IO t
run (Action act) = act
run (Pure val) = pure val
run (act >>= next) = do x <- run act
                        run (next x)
run (Spawn proc) = do Just pid <- spawn (run proc)
                      | Nothing => pure Nothing
                      pure (Just (MkMessage pid))
run (Request (MkMessage pid) msg)
  = do Just chan <- connect pid
       | _ => pure Nothing
       ok <- unsafeSend chan msg
       if ok then do Just x <- unsafeRecv Nat chan
                     | Nothing => pure Nothing
                     pure (Just x)
              else pure Nothing
run (Respond calc)
  = do Just sender <- listen 1
       | Nothing => pure Nothing
       Just msg <- unsafeRecv Message sender
       | Nothing => pure Nothing
       res <- run (calc msg)
       unsafeSend sender res
       pure (Just msg)
run (Loop act) = run act

procAdder : Process ()
procAdder = do Respond (\msg => case msg of
                                  Add x y => Pure (x + y))
               Loop procAdder

procMain : Process ()
procMain = do Just adder_id <- Spawn procAdder
              | Nothing => Action (putStrLn "Spawn failed")
              Just answer <- Request adder_id (Add 2 3)
              | Nothing => Action (putStrLn "Request failed")
              Action (printLn answer)

-- run with:
-- :exec run procMain


module Graph.API

import Graph.Core

%access export

noNodes : Graph a b -> Nat
noNodes = length . labNodes

-- Not very useful, labNodes is enough
nodes : Graph a b -> List NodeID
nodes = map fst . labNodes

-- Same as nodes, labEdges is enough
-- edges

nodeRange : Graph a b -> (NodeID, NodeID)
nodeRange g = let vs = nodes g in (foldl1 min vs, foldl1 max vs)

labEdges : Graph a b -> List (LEdge b)
labEdges = ufold (\(p, node, _, s), acc =>
             (map (\(label, target) => (node, target, label)) s) ++
             (map (\(label, source) => (source, node, label)) p) ++
             acc) []

namespace Edge
  source : LEdge b -> NodeID
  source (s, _, _) = s
  target : LEdge b -> NodeID
  target (_, t, _) = t
  label : LEdge b -> b
  label (_, _, ec) = ec

namespace Node
  identifier : LNode b -> NodeID
  identifier (i, _) = i
  label : LNode b -> b
  label (_, nc) = nc

gmap : (Context a b -> Context c d) -> Graph a b -> Graph c d
gmap f = ufold (\c, g => (f c) & g) empty

nmap : (a -> c) -> Graph a b -> Graph c b
nmap f = gmap (\(ps, node, label, ss) => (ps, node, f label, ss))

private
map1 : (b -> c) -> List (b, Int) -> List (c, Int)
map1 f = map (\(label, node) => (f label, node))

emap : (b -> c) -> Graph a b -> Graph a c
emap f = gmap (\(ps, n, nc, ss) => (map1 f ps, n, nc, map1 f ss))

nemap : (a -> c) -> (b -> d) -> Graph a b -> Graph c d
nemap fn fe = gmap (\(ps, n, nc, ss) => (map1 fe ps, n, fn nc, map1 fe ss))

infixr 10 .: -- TODO choose right fixity

(.:) : (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = (.) . (.)

mcontext : Graph a b -> NodeID -> MContext a b
mcontext = fst .: flip match

context4l : Graph a b -> NodeID -> Adj b
context4l = maybe [] context4l' .: mcontext where
  context4l' : Context a b -> Adj b
  context4l' (p, v, _, s) = s ++ filter ((==v) . snd) p

out : Graph a b -> NodeID -> List (LEdge b)
out graph node = map (\(label, succ) => (node, succ, label))
                     (context4l graph node)


module Control.Monad.Logic.Logic

import public Control.Monad.Logic.Interface
import Control.Monad.Identity
import Control.Monad.Trans

-- import Data.Colist
import Data.List.Lazy -- this has more functions than `Data/Colist.idr`

public export
record LogicT (m : Type -> Type) (a : Type) where
  constructor MkLogicT
  runLogicT : forall r. (cons : a -> m r -> m r) -> (nil : m r) -> m r

public export
Logic : (a : Type) -> Type
Logic = LogicT Identity

public export
runLogic : Logic a -> (a -> r -> r) -> r -> r
runLogic xz cons nil = runIdentity $ runLogic xz (map . cons) (Id nil)

||| possibly useless due to cases of infinite branching in underlying monads' unfavorable control flow
public export
observeT : Applicative m => LogicT m a -> m (LazyList a)
observeT xz = runLogicT xz (\x, xs => map (\xs_ => x :: xs_) xs) (pure [])

public export
observe : Logic a -> LazyList a
observe = runIdentity . observeT

public export
Functor (LogicT m) where
  map f xz = MkLogicT $ \cons, nil => runLogicT xz (\x, xs => cons (f x) xs) nil

public export
Applicative (LogicT m) where
  pure x = MkLogicT $ \cons, nil => cons x nil
  fz <*> xz = MkLogicT $ \cons, nil => runLogicT fz (\f, fs => runLogicT xz (\x, xs => cons (f x) xs) fs) nil

public export
Monad (LogicT m) where
  act >>= react = MkLogicT $ \cons, nil => runLogicT act (\r, rs => runLogicT (react r) cons rs) nil

public export
Alternative (LogicT m) where
  empty = MkLogicT $ \cons, nil => nil
  xz <|> yz = MkLogicT $ \cons, nil => runLogicT xz cons (runLogicT yz cons nil)

public export
MonadTrans LogicT where
  lift xz = MkLogicT $ \cons, nil => xz >>= \x => cons x nil

export
HasIO m => HasIO (LogicT m) where
  liftIO = lift . liftIO

public export
Monad m => MonadLogic (LogicT m) where
  split xz = lift $ runLogicT xz (\cons, nil => pure $ Just (cons, lift nil >>= reflect)) (pure Nothing)


module TypeTrans.Transformations

import TypeTrans.AST
import Data.Vect

incrDim : Nat -> TypeT -> Maybe TypeT
incrDim Z __ = Nothing
incrDim m (Vec sz tp) =
  if nsz * m == sz
    then Just (Vec m (Vec nsz tp))
    else Nothing
  where
    nsz = sz `div` m
incrDim _ _ = Nothing

redDim : TypeT -> Maybe TypeT
redDim  (Vec sz1 (Vec sz2 tp)) = Just (Vec (sz1 * sz2) tp)
redDim _ = Nothing

{-
splitMap : Int -> Action -> Action
splitMap m (Map v a) = Compose [Merge m, Map v (Map v a), Split m]

splitFold : Int -> Action -> Action
splitFold m (Fold v fa acc) =  Compose [Fold v (Fold v fa acc) acc, Split m]

splitAssocFoldByMap : Int -> Action -> Action
splitAssocFoldByMap m (Fold v afa acc) = Compose [Fold v afa acc, Map v (Fold v afa acc), Split m]

liftMapCompose : Action -> Action
liftMapCompose (Map v (Compose as)) = Compose (map (Map v) as)

-- Check
liftComposeMap : Action -> Action
liftComposeMap (Compose ((Map v a)::xs)) = Map v (Compose as)
    where
        as = map (\(Map _ a) => a) ((Map v a)::xs)

splitCompose : Action -> Action
splitCompose (Compose (a::as)) = Compose [a,Compose as]

mergeCompose : Action -> Action
mergeCompose (Compose (a::Compose as::[])) = Compose (a::as)
-- -----------------------------
--

combineSplitMerge : Action -> Action -> Action
combineSplitMerge s m =
    let
        Split n1 = s
        Merge n2 = m
    in
        Distr n1 n2

combineSplitDistr : Action -> Action -> Action
combineSplitDistr s m =
    let
        Split n1 = s
        Distr n2 n3 = m
    in
        Distr n1 n3 -- CHECK!!

combineDistrMerge : Action -> Action -> Action
combineDistrMerge s m =
    let
        Distr n1 n2= s
        Merge n3 = m
    in
        Distr n1 n3

joinSplitMerge_helper : ((Action -> Action -> Action) , (Action -> Bool) , (Action -> Bool),
                          List Action, List Action)  -> List Action
joinSplitMerge_helper (comb, t1, t2, [], as') = as'
joinSplitMerge_helper (comb, t1, t2, s::m::ras, as') =
    if (t1 s && t2 m)
      then
        joinSplitMerge_helper (comb, t1, t2,ras, (as'++[comb s m]))
      else
        joinSplitMerge_helper (comb, t1, t2,(m::ras), (as'++[s]))

isSplit : Action -> Bool
isSplit (Split _) = True
isSplit _ = False

isMerge : Action -> Bool
isMerge (Merge _) = True
isMerge _ = False

isDistr : Action -> Bool
isDistr (Distr _ _) = True
isDistr _ = False

joinSplitMerge : Action -> Action
joinSplitMerge (Compose [a]) =  Compose [a]
joinSplitMerge (Compose []) =  Compose []
joinSplitMerge (Compose as) = Compose (joinSplitMerge_helper (combineSplitMerge, isSplit, isMerge, as, []))

joinSplitDistr : Action -> Action
joinSplitDistr (Compose [a]) =  Compose [a]
joinSplitDistr (Compose []) =  Compose []
joinSplitDistr (Compose as) = Compose (joinSplitMerge_helper (combineSplitDistr, isSplit, isDistr, as, []))

joinDistrMerge : Action -> Action
joinDistrMerge (Compose [a]) =  Compose [a]
joinDistrMerge (Compose []) =  Compose []
joinDistrMerge (Compose as) = Compose (joinSplitMerge_helper (combineDistrMerge, isDistr, isMerge, as, []))

-- -----------------------------
--TODO Check
letToNestedLet : Argument -> Argument
letToNestedLet (Let exprs res) = case exprs of
  (x::xs) => (Let exprs res)
  -- Need verbosity of x1::x2::xs for automatic proof checker to
  -- infer that exprs is non empty
  (x1::x2::xs) => letToNestedLet (Let (init (x1::x2::xs))
                    (Let [Prelude.List.last (x1::x2::xs)] res))

-- TODO check, doesn't make sense
-- Lambda [Argument] Argument -> Action
-- Let [(Argument, Argument)] Argument -> Argument
-- Res Action Argument -> Argument
--letToLambda : Argument -> Argument
--letToLambda (Let [(lhs, rhs)] res) = Res (Lambda lhs res) rhs
-}


||| This module is inspired by the open union used in the paper
||| Freer Monads, More Extensible Effects
||| by Oleg Kiselyov and Hiromi Ishii
|||
||| By using an AtIndex proof, we are able to get rid of all of the unsafe
||| coercions in the original module.

module Data.OpenUnion

import Data.DPair
import Data.List.AtIndex
import Data.List.HasLength
import Data.Nat
import Data.Nat.Order.Properties
import Decidable.Equality
import Syntax.WithProof

%default total

||| An open union of families is an index picking a family out together with
||| a value in the family thus picked.
public export
data Union : (elt : a -> Type) -> (ts : List a) -> Type where
  Element : (k : Nat) -> (0 _ : AtIndex t ts k) -> elt t -> Union elt ts

||| An empty open union of families is empty
public export
Uninhabited (Union elt []) where
  uninhabited (Element _ p _) = void (uninhabited p)

||| Injecting a value into an open union, provided we know the index of
||| the appropriate type family.
inj' : (k : Nat) -> (0 _ : AtIndex t ts k) -> elt t -> Union elt ts
inj' = Element

||| Projecting out of an open union, provided we know the index of the
||| appropriate type family. This may obviously fail if the value stored
||| actually corresponds to another family.
prj' : (k : Nat) -> (0 _ : AtIndex t ts k) -> Union elt ts -> Maybe (elt t)
prj' k p (Element k' q t) with (decEq k  k')
  prj' k p (Element k q t) | Yes Refl = rewrite atIndexUnique p q in Just t
  prj' k p (Element k' q t) | No neq = Nothing

||| Given that equality of type families is not decidable, we have to
||| rely on the interface `Member` to automatically find the index of a
||| given family.
public export
inj : Member t ts => elt t -> Union elt ts
inj = let (Element n p) = isMember t ts in inj' n p

||| Given that equality of type families is not decidable, we have to
||| rely on the interface `Member` to automatically find the index of a
||| given family.
public export
prj : Member t ts => Union elt ts -> Maybe (elt t)
prj = let (Element n p) = isMember t ts in prj' n p

||| By doing a bit of arithmetic we can figure out whether the union's value
||| came from the left or the right list used in the index.
public export
split : Subset Nat (HasLength ss) ->
        Union elt (ss ++ ts) -> Either (Union elt ss) (Union elt ts)
split m (Element n p t) with (@@ lt n (fst m))
  split m (Element n p t) | (True ** lt)
    = Left (Element n (strengthenL m lt p) t)
  split m (Element n p t) | (False ** notlt)
    = let 0 lte : lte (fst m) n === True
                = LteIslte (fst m) n (notltIsGTE n (fst m) notlt)
      in Right (Element (minus n (fst m)) (strengthenR m lte p) t)

||| We can inspect an open union over a non-empty list of families to check
||| whether the value it contains belongs either to the first family or any
||| other in the tail.
public export
decomp : Union elt (t :: ts) -> Either (Union elt ts) (elt t)
decomp (Element 0     (Z)   t) = Right t
decomp (Element (S n) (S p) t) = Left (Element n p t)

||| An open union over a singleton list is just a wrapper
public export
decomp0 : Union elt [t] -> elt t
decomp0 elt = case decomp elt of
  Left t => absurd t
  Right t => t

||| Inserting new union members on the right leaves the index unchanged.
public export
weakenR : Union elt ts -> Union elt (ts ++ us)
weakenR (Element n p t) = Element n (weakenR p) t

||| Inserting new union members on the left, requires shifting the index by
||| the number of members introduced. Note that this number is the only
||| thing we need to keep around at runtime.
public export
weakenL : Subset Nat (HasLength ss) -> Union elt ts -> Union elt (ss ++ ts)
weakenL m (Element n p t) = Element (fst m + n) (weakenL m p) t


module Control.Monad.List

import Control.HigherOrder

import Control.Monad.Trans

public export
data ListM : (Type -> Type) -> (Type -> Type) where
  Nil : ListM m a
  (::) : a -> m (ListM m a) -> ListM m a

public export
0
ListT : (Type -> Type) -> (Type -> Type)
ListT m a = m (ListM m a)

namespace Semigroup

  export
  [ListT] Monad m => Semigroup (ListT m a) where
    xs <+> ys =
      case !xs of
        [] => ys -- No idea it can't find the instance automatically.
        (x :: xs) => pure $ x :: ((<+>) @{ListT} xs ys)

  export
  [ListM] Monad m => Semigroup (ListM m a) where
    [] <+> ys = ys
    (x :: xs) <+> ys = x :: (<+>) @{ListT} xs (pure ys)

  %hint export
  ListTSemigroup : Monad m => Semigroup (ListT m a)
  ListTSemigroup = Semigroup.ListT

namespace Monoid
  %hint
  export
  ListT : Monad m => Monoid (ListT m a)
  ListT = MkMonoid @{Semigroup.ListT} (pure [])

  %hint
  export
  ListM : Monad m => Monoid (ListM m a)
  ListM = MkMonoid @{Semigroup.ListM} []

namespace Functor
  mutual
    export
    [ListM] Functor m => Functor (ListM m) where
      map f [] = []
      map f (x :: xs) = f x :: map @{ListT} f xs

    export
    [ListT] Functor m => Functor (ListT m) where
      map f x = map (map @{ListM} f) x

namespace Applicative
  %hint export
  ListT : Monad m => Applicative (ListT m)
  ListT = MkApplicative @{Functor.ListT}
    (pure . (:: pure Nil))
    $
    \fs, ys =>
      case !fs of
        [] => pure []
        f :: fs => (<+>) @{Semigroup.ListT}
          (map @{Functor.ListT} f ys)
          ((<*>) @{Applicative.ListT} fs ys)

namespace Monad

  bind : Monad m => ListT m a -> (a -> ListT m b) -> ListT m b
  bind xs f = do
    case !xs of
      [] => pure []
      x :: xs => (<+>) @{ListT} (f x) (bind xs f)

  %hint export
  ListT : Monad m => Monad (ListT m)
  ListT = MkMonad @{Applicative.ListT}
    (bind {m})
    (flip (bind {m}) id)

namespace Alternative
  %hint public export
  ListT : Monad m => Alternative (ListT m)
  ListT = MkAlternative @{Applicative.ListT} (pure []) (\x, y => (<+>) @{ListT} x y)

export
MonadTrans ListT where
  lift = (>>= pure @{ListT})

export
runListT' : Monad m => ListT m a -> m (Maybe a)
runListT' x = do
  case !x of
    [] => pure Nothing
    x :: xs => pure (Just x)

export
runListT : Monad m => ListT m a -> m (List a)
runListT x = do
  case !x of
    [] => pure []
    x :: xs => map (x ::) (runListT xs)

export
liftList : Applicative m => List a -> ListT m a
liftList [] = pure []
liftList (x :: xs) = pure (x :: liftList xs)


module SmallStep

import Logic

%access public export

%default total

data Tm : Type where
  C : Nat -> Tm
  P : Tm -> Tm -> Tm

Uninhabited (C _ = P _ _) where
  uninhabited Refl impossible

Uninhabited (P _ _ = C _) where
  uninhabited Refl impossible

evalF : (t : Tm) -> Nat
evalF (C n) = n
evalF (P n m) = evalF n + evalF m

data Eval : Tm -> Nat -> Type where
  E_Const : Eval (C n) n
  E_Plus : Eval t1 n1 -> Eval t2 n2 -> Eval (P t1 t2) (n1 + n2)

infixl 5 =+>

(=+>) : (t : Tm) -> (n : Nat) -> Type
(=+>) = Eval

infix 4 -+>

data Value : Tm -> Type where
  V_Const : (n : Nat) -> Value (C n)

Uninhabited (Value (P _ _)) where
  uninhabited (V_Const _) impossible

data Step : Tm -> Tm -> Type where
  ST_PlusConstConst : Step (P (C n1) (C n2)) (C (n1 + n2))
  ST_Plus1 : Step t1 t1' -> Step (P t1 t2) (P t1' t2)
  ST_Plus2 : Value v1 -> Step t2 t2' -> Step (P v1 t2) (P v1 t2')

(-+>) : Tm -> Tm -> Type
(-+>) = Step

test_step_1 : P (P (C 0) (C 3)) (P (C 2) (C 4)) -+>
              P (C (0 + 3)) (P (C 2) (C 4))
test_step_1 = ST_Plus1 ST_PlusConstConst

test_step_2 : P (C 0) (P (C 2) (P (C 0) (C 3))) -+>
              P (C 0) (P (C 2) (C (0 + 3)))
test_step_2 = ST_Plus2 (V_Const 0) (ST_Plus2 (V_Const 2) ST_PlusConstConst)

step_deterministic : Deterministic Step
step_deterministic ST_PlusConstConst ST_PlusConstConst =
  Refl
step_deterministic (ST_Plus1 s1) (ST_Plus1 s2) =
  rewrite step_deterministic s1 s2 in Refl
step_deterministic (ST_Plus2 _ s1) (ST_Plus2 _ s2) =
  rewrite step_deterministic s1 s2 in Refl

strong_progress : (t : Tm) -> Either (Value t) (t' : Tm ** t -+> t')
strong_progress (C n) = Left (V_Const n)
strong_progress (P (C n) (C m)) = Right (C (n + m) ** ST_PlusConstConst)
strong_progress (P (C n) (P t1 t2)) = case strong_progress (P t1 t2) of
  Left _ impossible
  Right (t' ** s) => Right (P (C n) t' ** ST_Plus2 (V_Const n) s)
strong_progress (P (P t1 t2) t3) = case strong_progress (P t1 t2) of
  Left _ impossible
  Right (t' ** s) => Right (P t' t3 ** ST_Plus1 s)

value_is_nf : Value v -> NormalForm Step v
value_is_nf (V_Const _) (_ ** _) impossible

nf_is_value : NormalForm Step v -> Value v
nf_is_value {v = (C k)} _ = V_Const k
nf_is_value {v = (P (C k) (C j))} contra =
  absurd (contra (C (k + j) ** ST_PlusConstConst))
nf_is_value {v = (P (C k) (P t1 t2))} contra = case strong_progress (P t1 t2) of
  Left _ impossible
  Right (x' ** s) => absurd (contra (P (C k) x' ** ST_Plus2 (V_Const k) s))
nf_is_value {v = (P (P t1 t2) t3)} contra = case strong_progress (P t1 t2) of
  Left _ impossible
  Right (x' ** s) => absurd (contra (P x' t3 ** ST_Plus1 s))

nf_same_as_value : (NormalForm Step v) ↔ (Value v)
nf_same_as_value = (nf_is_value, value_is_nf)

namespace Temp1
  data Value1 : Tm -> Type where
    V_Const1 : (n : Nat) -> Value1 (C n)
    V_Funny1 : Value1 (P t1 (C n2))

  data Step1 : Tm -> Tm -> Type where
    ST_PlusConstConst1 : Step1 (P (C n1) (C n2)) (C (n1 + n2))
    ST_Plus11 : Step1 t1 t1' -> Step1 (P t1 t2) (P t1' t2)
    ST_Plus21 : Value1 v1 -> Step1 t2 t2' -> Step1 (P v1 t2) (P v1 t2')

  value1_not_same_as_normal_form : (v : Tm ** ( Value1 v
                                              , Not (NormalForm Step1 v) ))
  value1_not_same_as_normal_form =
    (P (C 0) (C 0) ** (V_Funny1, \contra => contra (C 0 ** ST_PlusConstConst1)))

namespace Temp2
  data Value2 : Tm -> Type where
    V_Const2 : (n : Nat) -> Value2 (C n)

  data Step2 : Tm -> Tm -> Type where
    ST_Funny2 : Step2 (C n) (P (C n) (C 0))
    ST_PlusConstConst2 : Step2 (P (C n1) (C n2)) (C (n1 + n2))
    ST_Plus12 : Step2 t1 t1' -> Step2 (P t1 t2) (P t1' t2)
    ST_Plus22 : Value2 v1 -> Step2 t1 t2' -> Step2 (P v1 t2) (P v1 t2')

  value2_not_same_as_normal_form : (v : Tm ** ( Value2 v
                                              , Not (NormalForm Step2 v) ))
  value2_not_same_as_normal_form =
    (C 0 ** (V_Const2 0, \contra => contra (P (C 0) (C 0) ** ST_Funny2)))

namespace Temp3
  data Value3 : Tm -> Type where
    V_Const3 : (n : Nat) -> Value3 (C n)

  data Step3 : Tm -> Tm -> Type where
    ST_PlusConstConst3 : Step3 (P (C n1) (C n2)) (C (n1 + n2))
    ST_Plus13 : Step3 t1 t1' -> Step3 (P t1 t2) (P t1' t2)

  value3_not_same_as_normal_form : (v : Tm ** ( Not (Value3 v)
                                              , NormalForm Step3 v ))
  value3_not_same_as_normal_form =
    (P (C 0) (P (C 0) (C 0)) ** ( \v => case v of
                                    V_Const3 _ impossible
                                , \(x' ** s) => case s of
                                    ST_Plus13 ST_PlusConstConst3 impossible
                                    ST_Plus13 (ST_Plus13 _) impossible ))

namespace Temp4
  data Tm4 : Type where
    Tru4 : Tm4
    Fls4 : Tm4
    Test4 : Tm4 -> Tm4 -> Tm4 -> Tm4

  data Value4 : Tm4 -> Type where
    V_Tru4 : Value4 Tru4
    V_Fls4 : Value4 Fls4

  data Step4 : Tm4 -> Tm4 -> Type where
    ST_IfTrue4 : Step4 (Test4 Tru4 t1 t2) t1
    ST_IfFalse4 : Step4 (Test4 Fls4 t1 t2) t2
    ST_If4 : Step4 t1 t1' -> Step4 (Test4 t1 t2 t3) (Test4 t1' t2 t3)

  bool_step_prop1 : Not (Step4 Fls4 Fls4)
  bool_step_prop1 ST_IfTrue4 impossible
  bool_step_prop1 ST_IfFalse4 impossible
  bool_step_prop1 (ST_If4 _) impossible

  bool_step_prop2 : Not (Step4 (Test4 Tru4
                                      (Test4 Tru4 Tru4 Tru4)
                                      (Test4 Fls4 Fls4 Fls4))
                               Tru4)
  bool_step_prop2 ST_IfTrue4 impossible
  bool_step_prop2 ST_IfFalse4 impossible
  bool_step_prop2 (ST_If4 _) impossible

  bool_step_prop3 : Step4 (Test4 (Test4 Tru4 Tru4 Tru4)
                                 (Test4 Tru4 Tru4 Tru4)
                                 Fls4)
                          (Test4 Tru4
                                 (Test4 Tru4 Tru4 Tru4)
                                 Fls4)
  bool_step_prop3 = ST_If4 ST_IfTrue4

  strong_progress_bool : (t : Tm4) -> Either (Value4 t) (t' : Tm4 ** Step4 t t')
  strong_progress_bool Tru4 = Left V_Tru4
  strong_progress_bool Fls4 = Left V_Fls4
  strong_progress_bool (Test4 Tru4 t2 _) = Right (t2 ** ST_IfTrue4)
  strong_progress_bool (Test4 Fls4 _ t3) = Right (t3 ** ST_IfFalse4)
  strong_progress_bool (Test4 (Test4 t1 t2 t3) t4 t5) =
    case strong_progress_bool (Test4 t1 t2 t3) of
      Left _ impossible
      Right (t' ** s) => Right (Test4 t' t4 t5 ** ST_If4 s)

  step_deterministic_bool : Step4 x y1 -> Step4 x y2 -> y1 = y2
  step_deterministic_bool ST_IfTrue4 ST_IfTrue4 = Refl
  step_deterministic_bool ST_IfFalse4 ST_IfFalse4 = Refl
  step_deterministic_bool (ST_If4 s1) (ST_If4 s2) =
    rewrite step_deterministic_bool s1 s2 in Refl

infix 4 -+>*

(-+>*) : Relation Tm
(-+>*) = Multi Step

test_multistep_1 : P (P (C 0) (C 3)) (P (C 2) (C 4)) -+>* C 9
test_multistep_1 = MultiStep (ST_Plus1 ST_PlusConstConst) $
                   MultiStep (ST_Plus2 (V_Const 3) ST_PlusConstConst) $
                   MultiStep ST_PlusConstConst $
                   MultiRefl

test_multistep_2 : C 3 -+>* C 3
test_multistep_2 = MultiRefl

test_multistep_3 : P (C 0) (C 3) -+>* P (C 0) (C 3)
test_multistep_3 = MultiRefl

test_multistep_4 : P (C 0) (P (C 2) (P (C 0) (C 3))) -+>* P (C 0) (C 5)
test_multistep_4 = MultiStep (ST_Plus2 (V_Const 0)
                                       (ST_Plus2 (V_Const 2)
                                                 ST_PlusConstConst)) $
                   MultiStep (ST_Plus2 (V_Const 0) ST_PlusConstConst) $
                   MultiRefl

NormalFormOf : (t, t' : Tm) -> Type
NormalFormOf t t' = (t -+>* t', NormalForm Step t')

normal_forms_unique : Deterministic NormalFormOf
normal_forms_unique (MultiRefl, _) (MultiRefl, _) = Refl
normal_forms_unique (MultiRefl, contra) (MultiStep {y} x_step_y _, _) =
  absurd (contra (y ** x_step_y))
normal_forms_unique (MultiStep {y} x_step_y _, _) (MultiRefl, contra) =
  absurd (contra (y ** x_step_y))
normal_forms_unique {y2}
                    p@(MultiStep x_step_y y_step_y1, contra1)
                    (MultiStep x_step_y3 y3_step_y2, contra2) =
  let y3_eq_y = sym (step_deterministic x_step_y x_step_y3)
      y_step_y2 = replace {P=\x => Multi Step x y2} y3_eq_y y3_step_y2
  in normal_forms_unique (assert_smaller p (y_step_y1, contra1))
                         (y_step_y2, contra2)

Normalizing : (r : Relation t) -> Type
Normalizing {t} r = (x : t) -> (y : t ** (Multi r x y, NormalForm r y))

multistep_congr_1 : t1 -+>* t1' -> P t1 t2 -+>* P t1' t2
multistep_congr_1 MultiRefl = MultiRefl
multistep_congr_1 (MultiStep once next) =
  MultiStep (ST_Plus1 once) (multistep_congr_1 next)

multistep_congr_2 : Value t1 -> t2 -+>* t2' -> P t1 t2 -+>* P t1 t2'
multistep_congr_2 _ MultiRefl = MultiRefl
multistep_congr_2 v (MultiStep once next) =
  MultiStep (ST_Plus2 v once) (multistep_congr_2 v next)

step_normalizing : Normalizing Step
step_normalizing (C n) =
  (C n ** (MultiRefl, \(_ ** s) => case s of
                        ST_PlusConstConst impossible
                        ST_Plus1 _ impossible
                        ST_Plus2 _ _ impossible))
step_normalizing (P t1 t2) =
  let (_ ** (s1, nf1)) = step_normalizing t1
      (_ ** (s2, nf2)) = step_normalizing t2
      v1@(V_Const n1) = nf_is_value nf1
      V_Const n2 = nf_is_value nf2
      steps = multi_trans (multistep_congr_1 {t2=t2} s1) $
              multi_trans (multistep_congr_2 v1 s2) $
              MultiStep ST_PlusConstConst MultiRefl
  in (C (n1 + n2) ** (steps, \(_ ** s) => case s of
                               ST_PlusConstConst impossible
                               ST_Plus1 _ impossible
                               ST_Plus2 _ _ impossible))

eval__multistep : t =+> n -> t -+>* C n
eval__multistep E_Const = MultiRefl
eval__multistep (E_Plus {n1} e1 e2) =
  multi_trans (multistep_congr_1 (eval__multistep e1)) $
  multi_trans (multistep_congr_2 (V_Const n1) (eval__multistep e2)) $
  MultiStep ST_PlusConstConst MultiRefl

step__eval : t -+> t' -> t' =+> n -> t =+> n
step__eval ST_PlusConstConst E_Const = E_Plus E_Const E_Const
step__eval (ST_Plus1 s1) (E_Plus e1 e2) = E_Plus (step__eval s1 e1) e2
step__eval (ST_Plus2 _ s2) (E_Plus e1 e2) = E_Plus e1 (step__eval s2 e2)

multistep__eval : NormalFormOf t t' -> (n : Nat ** (t' = C n, t =+> n))
multistep__eval (MultiRefl, nf) =
  let V_Const n = nf_is_value nf
  in (n ** (Refl, E_Const))
multistep__eval p@(MultiStep {y} once next, nf) =
  let (n ** (prf, e)) = multistep__eval (assert_smaller p (next, nf))
  in (n ** (prf, step__eval once e))

evalF_eval : (evalF t = n) ↔ (t =+> n)
evalF_eval = (forward, backward)
where forward : evalF t = n -> t =+> n
      forward {t = (C _)} prf = rewrite prf in E_Const
      forward {t = (P t1 t2)} prf with (evalF t1) proof prf1
        forward {t = (P t1 t2)} prf | _ with (evalF t2) proof prf2
          forward {t = (P t1 t2)} prf | _ | _ =
            rewrite sym prf
            in E_Plus (forward (sym prf1)) (forward (sym prf2))
      backward : t =+> n -> evalF t = n
      backward E_Const = Refl
      backward (E_Plus e1 e2) =
        rewrite backward e1
        in rewrite backward e2
        in Refl


||| A segment is a compositional fragment of a telescope.
||| A key difference is that segments are right-nested, whereas
||| telescopes are left nested.
||| So telescopes are convenient for well-bracketing dependencies,
||| but segments are convenient for processing telescopes from left
||| to right.
|||
||| As with telescopes, indexing segments by their length (hopefully)
||| helps the type-checker infer stuff.
module Data.Telescope.Segment

import Data.Telescope.Telescope

import Syntax.PreorderReasoning
import Data.Fin
import Data.Nat
import Data.DPair

%default total

||| A segment is a compositional fragment of a telescope, indexed by
||| the segment's length.
public export
data Segment : (n : Nat) -> Left.Telescope k -> Type where
  Nil  : Segment 0 gamma
  (::) : (ty : TypeIn gamma) -> (delta : Segment n (gamma -. ty)) -> Segment (S n) gamma

||| A segment of size `n` indexed by `gamma` can be seen as the tabulation of a
||| function that turns environments for `gamma` into telescopes of size `n`.
public export
tabulate : (n : Nat) -> (Left.Environment gamma -> Left.Telescope n) -> Segment n gamma
tabulate Z tel = []
tabulate (S n) tel = (sigma :: tabulate n (uncurry delta)) where

  sigma : TypeIn gamma
  sigma env = fst (uncons (tel env))

  delta : (env : Environment gamma) -> sigma env -> Left.Telescope n
  delta env v with (uncons (tel env))
    delta env v | (sig ** delt ** _) = delt v

||| Any telescope is a segment in the empty telescope. It amounts to looking
||| at it left-to-right instead of right-to-left.
public export
fromTelescope : {k : Nat} -> Left.Telescope k -> Segment k []
fromTelescope gamma = tabulate _ (const gamma)

||| Conversely, a segment of size `n` in telescope `gamma` can be seen as a function
||| from environments for `gamma` to telescopes of size `n`.
public export
untabulate : {n : Nat} -> Segment n gamma -> (Left.Environment gamma -> Left.Telescope n)
untabulate []            _   = []
untabulate (ty :: delta) env = cons (ty env) (untabulate delta . (\ v => (env ** v)))

||| Any segment in the empty telescope correspond to a telescope.
public export
toTelescope : {k : Nat} -> Segment k [] -> Left.Telescope k
toTelescope seg = untabulate seg ()

%name Segment delta,delta',delta1,delta2

infixl 3 |++, :++

||| This lemma comes up all the time when mixing induction on Nat with
||| indexing modulo addition.  An alternative is to use something like
||| frex.
succLemma : (lft, rgt : Nat) -> lft + (S rgt) = S (lft + rgt)
succLemma x y = Calc $
  |~ x + (1 + y)
  ~~ (x + 1)+ y  ...(plusAssociative x 1 y)
  ~~ (1 + x)+ y  ...(cong (+y) $ plusCommutative x 1)
  ~~ 1 + (x + y) ...(sym $ plusAssociative 1 x y)

-- Should go somehwere in stdlib
public export
keep : (0 prf : a ~=~ b) -> a ~=~ b
keep Refl = Refl

-- Keeping the `Nat` argument relevant, should (hopefully) only
-- case-split on it and not the environment unnecessarily, allowing us
-- to calculate, so long as we know the 'shape' of the Segment.
--
-- This should work in theory, I don't think it actually works for
-- Idris at the moment.  Might work in Agda?

||| Segments act on telescope from the right.
public export
(|++) : (gamma : Left.Telescope k) -> {n : Nat} -> (delta : Segment n gamma) -> Left.Telescope (n + k)
(|++)  gamma {n = 0} delta  = gamma
(|++)  gamma {n=S n} (ty :: delta) = rewrite sym $ succLemma n k in
                                       gamma -. ty |++ delta

||| Segments form a kind of an indexed monoid w.r.t. the action `(|++)`
public export
(++) : {gamma : Left.Telescope k}
    -> {n : Nat}
    -> (lft : Segment n  gamma         )
    -> (rgt : Segment m (gamma |++ lft))
    -> Segment (n + m) gamma
(++) {n = 0  } delta       rgt = rgt
(++) {n = S n} (ty :: lft) rgt = ty :: lft ++ rewrite succLemma n k in
                                              rgt
-- This monoid does act on telescopes:
export
actSegmentAssociative : (gamma : Left.Telescope k)
                     -> (lft : Segment n gamma)
                     -> (rgt : Segment m (gamma |++ lft))
                     -> (gamma |++ (lft ++ rgt)) ~=~ ((gamma |++ lft) |++ rgt)
actSegmentAssociative gamma {n = 0}   []          rgt = Refl
actSegmentAssociative gamma {n = S n} (ty :: lft) rgt =
  let rgt' : Segment {k = n + (S k)} m (gamma -. ty |++ lft)
      rgt' = rewrite succLemma n k in
             rgt
      rgt_eq_rgt' : rgt ~=~ rgt'
      rgt_eq_rgt' = rewrite succLemma n k in
                    Refl
  in
  rewrite sym $ succLemma (n + m) k in
  rewrite sym $ succLemma n       k in keep $ Calc $
  |~ ((gamma -. ty) |++ (lft ++ rgt'))
  ~~ ((gamma -. ty |++  lft) |++ rgt')
          ...(actSegmentAssociative (gamma -. ty) lft rgt')

public export
weaken : {0 gamma : Left.Telescope k}
      -> {delta : Segment n gamma} -> (sy : TypeIn gamma)
      -> TypeIn (gamma |++ delta)
weaken           {delta = []         } sy = sy
weaken {n = S n} {delta = ty :: delta} sy = rewrite sym $ succLemma n k in
                                            weaken (weakenTypeIn sy)

public export
projection : {0 gamma : Left.Telescope k}
          -> {n : Nat}
          -> {0 delta : Segment n gamma}
          -> Environment (gamma |++ delta)
          -> Environment gamma
projection {n = 0  } {delta = []         } env = env
projection {n = S n} {delta = ty :: delta} env
  = let (env' ** _) = projection {n} {delta}
                    $ rewrite succLemma n k in env
    in env'

infixl 4 .=

public export
data Environment : (env : Left.Environment gamma)
                -> (delta : Segment n gamma) -> Type where
  Empty : Environment env []
  (.=) : {0 gamma : Left.Telescope k} -> {0 ty : TypeIn gamma}
      -> {0 env   : Left.Environment gamma}
      -> {0 delta : Segment n (gamma -. ty)}

      -> (x : ty env) -> (xs : Segment.Environment (env ** x) delta)
      -> Environment env (ty :: delta)

public export
(:++) : {0 gamma : Left.Telescope k} -> {0 delta : Segment n gamma}
     -> (env : Left.Environment gamma)
     -> (ext : Segment.Environment env delta)
     ->        Left.Environment (gamma |++ delta)
(:++) env Empty = env
(:++) {n = S n} env (x .= xs) = rewrite sym $ succLemma n k in
                                (env ** x) :++ xs

-- This is too nasty for now, leave to later
{-
public export
break : {0 k : Nat} -> (gamma : Telescope k') -> (pos : Position gamma)
     -> {auto 0 ford : k' = cast pos + k } -> Telescope k
break gamma          FZ      {ford = Refl} = gamma
break []            (FS pos) {ford = _   } impossible
break {k' = S k'} (gamma -. ty) (FS pos) {ford} = break gamma pos
  {ford = Calc $
   |~ k'
   ~~ cast pos + k ...(succInjective _ _ ford)}

-- Should go into Data.Fin
export
lastIsLast : {n : Nat} -> cast (last {n}) = n
lastIsLast {n = 0  } = Refl
lastIsLast {n = S n} = rewrite lastIsLast {n} in
                       Refl

public export
finComplement : {n : Nat} -> (i : Fin n) -> Fin n
finComplement FZ = last
finComplement (FS i) = weaken (finComplement i)

export
castNaturality : (i : Fin n) -> finToNat (weaken i) ~=~ finToNat i
castNaturality  FZ    = Refl
castNaturality (FS i) = rewrite castNaturality i in
                        Refl

export
finComplementSpec : (i : Fin (S n)) -> cast i + cast (finComplement i) = n
finComplementSpec FZ = keep lastIsLast
finComplementSpec {n = .(S n)} (FS i@ FZ   ) = rewrite castNaturality (finComplement i) in
                                               rewrite finComplementSpec i in
                                               Refl
finComplementSpec {n = .(S n)} (FS i@(FS _)) = rewrite castNaturality (finComplement i) in
                                               rewrite finComplementSpec i in
                                               Refl

complementLastZero : (n : Nat) -> finComplement (last {n}) = FZ
complementLastZero n = finToNatInjective _ _ $ plusLeftCancel n _ _ $ Calc $
   let n' : Nat
       n' = cast $ finComplement $ last {n} in
   |~ n + n'
   ~~ (finToNat $ last {n})  + n'
                    ...(cong (+n') $ sym $ lastIsLast {n})
   ~~ n             ...(finComplementSpec $ last {n})
   ~~ n         + 0 ...(sym $ plusZeroRightNeutral n)

public export
breakOnto : {0 k,k' : Nat} -> (gamma : Telescope k) -> (pos : Position gamma)
         -> (delta : Segment n gamma)
         -> {auto 0 ford1 : k' === (finToNat $ finComplement pos) }
         -> {default
               -- disgusting, sorry
               (replace {p = \u => k = finToNat pos + u}
                        (sym ford1)
                        (sym $ finComplementSpec pos))
             0 ford2 : (k === ((finToNat pos) + k')) }
         -> Segment (cast pos + n)
                    (break {k = k'}
                           gamma pos
                           {ford = ford2})
breakOnto gamma          FZ      delta {ford1 = Refl} {ford2} =
                         rewrite sym ford2 in
                         delta
breakOnto (gamma -. ty) (FS pos) delta {ford1 = Refl} {ford2} =
                         rewrite sym $ succLemma (cast pos) n in
                         rewrite castNaturality (finComplement pos) in
                         breakOnto gamma pos (ty :: delta)

uip : (prf1, prf2 : x ~=~ y) -> prf1 ~=~ prf2
uip Refl Refl = Refl

export
breakStartEmpty : (gamma : Telescope k')
               -> {auto 0 ford1 : k = 0}
               -> {auto 0 ford2 : k' = finToNat (start gamma) + k}
               -> break {k} {k'} gamma (start gamma) {ford = ford2}
                ~=~ Telescope.Nil
breakStartEmpty [] {ford1 = Refl} {ford2 = Refl}            = Refl
breakStartEmpty {k} {k' = S k'} {ford1} {ford2} (gamma -. ty) =
                -- Yuck!
                let 0 u : (k' = finToNat (start gamma) + k)
                    u = succInjective _ _ ford2
                    v : break {k} {k'} gamma (start gamma) {ford = u}
                        ~=~ Telescope.Nil
                    v = breakStartEmpty {k} {k'} gamma {ford2 = u}
                in replace {p = \z =>
                             Equal {a = Telescope k} {b = Telescope 0}
                                   (break {k'} {k} gamma (start gamma)
                                          {ford = z})
                                          []
                        }
                        (uip u _)
                        (keep v)

public export
projection : {0 gamma : Telescope k} -> (pos : Position gamma) -> (env : Environment gamma)
          -> Environment (break {k = cast (finComplement pos)} gamma pos
                                {ford = sym $ finComplementSpec pos})
projection FZ env = rewrite finComplementSpec $ FZ {k} in
                    env
projection {gamma = []} (FS pos) Empty impossible
projection {k = S k} {gamma = gamma -. ty} (FS pos) (env ** x) =
  rewrite castNaturality (finComplement pos) in
  projection {k} pos env
-}


module Main

import System

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

guess : (target : Nat) -> (guesses: Nat) -> IO ()
guess target k = do putStrLn ("Number of tries: " ++ show k)
                    putStr "Guess number: "
                    Just input <- readNumber
                        | Nothing => do putStrLn "NaN"
                                        guess target (S k)
                    case compare input target of
                         LT => do putStrLn "Number too small"
                                  guess target (S k)
                         GT => do putStrLn "Number too big"
                                  guess target (S k)
                         EQ => putStrLn "Congrats! That's the number."

generateNrToGuess : IO (Nat)
generateNrToGuess = do timeValue <- time
                       let nrToGuess = mod timeValue 100
                       putStrLn ("Number to guess: " ++ show nrToGuess)
                       pure (fromIntegerNat nrToGuess)

main : IO()
main = do target <- generateNrToGuess
          guess target 0

repl2 : (prompt : String) -> (onInput : String -> String) -> IO ()
repl2 prompt onInput = do putStr prompt
                          input <- getLine
                          putStrLn (onInput input)
                          repl2 prompt onInput

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

testRepl2 : IO ()
testRepl2 = repl2 "Put string: " (\x => "Input string was: " ++ show x)

func : Integer -> String -> Maybe (String, Integer)
func sum input = if all isDigit (unpack input)
                    then let result = (cast input) + sum in
                         Just ("Sum: " ++ show result ++ "\n", result)
                    else Nothing

testReplWith : IO ()
testReplWith =
  replWith 0 "Add number: " func

testReplWith2 : IO()
testReplWith2 =
  replWith2 0 "Add number: " func


fstDup: (xs : List a) -> map fst (map dup xs) === xs
fstDup Nil = Refl
fstDup (x::xs) = ?a


partial
bar : (n : Nat) -> (m : Nat) -> n = m -> Nat
bar (S m) (S m) (Refl {x = S m}) = m

data Baz : Int -> Type where
     AddThings : (x : Int) -> (y : Int) -> Baz (x + y)

addBaz : (x : Int) -> Baz x -> Int
addBaz (x + y) (AddThings x y) = x + y

-- Not allowed in Idris 2, we use unification rather than matching!
-- addBaz2 : (x : Int) -> Baz x -> Int
-- addBaz2 (_ + _) (AddThings x y) = x + y

-- Also not allowed in Idris 2!
-- addBaz3 : (x : Int) -> Baz x -> Int
-- addBaz3 (x + y) (AddThings _ _) = x + y


import Aoc
import Data.Strings
import Data.SortedMap

band : Integer -> Integer -> Integer
band = prim__and_Integer

bor : Integer -> Integer -> Integer
bor = prim__or_Integer

bxor : Integer -> Integer -> Integer
bxor i j = cast $ prim__xor_Int (cast i) (cast j)

||| surrounded "[" "]" "[abcd]" == Just "abcd"
||| surrounded "[" "]" "[abc" == Nothing
surrounded : String -> String -> String -> Maybe String
surrounded l r s =
  let le = cast . length
  in if (l `isPrefixOf` s) && (r `isSuffixOf` s)
    then Just $ strSubstr (le l) (le s - le l - le r) s
    else Nothing

record Mask where
  constructor mkMask
  nonZeros : Integer
  ones : Integer
  floatXors : List Integer

mask0 : Mask
mask0 = mkMask 0 0 [0]

applyMask : Mask -> Integer -> Integer
applyMask m = bor m.ones . band m.nonZeros

applyMaskIndex : Mask -> Integer -> List Integer
applyMaskIndex m i = map (bxor (bor m.ones i)) m.floatXors

record State where
  constructor mkState
  mask : Mask
  memory : SortedMap Integer Integer

state0 : State
state0 = mkState mask0 empty

data Instruction = SetMask Mask | SetMem Integer Integer

parseMask : String -> Maybe Mask
parseMask = map (foldl go mask0) . traverse parseChar . unpack
  where
    data MaskChar = X | Zero | One
    parseChar : Char -> Maybe MaskChar
    parseChar 'X' = Just X
    parseChar '0' = Just Zero
    parseChar '1' = Just One
    parseChar _ = Nothing
    go : Mask -> MaskChar -> Mask
    go (mkMask nz o fx) X    = mkMask (2*nz+1) (2*o)   [2*x+i | x<-fx, i<-[0,1]]
    go (mkMask nz o fx) Zero = mkMask (2*nz)   (2*o)   (map (2*) fx)
    go (mkMask nz o fx) One  = mkMask (2*nz+1) (2*o+1) (map (2*) fx)

parseInstruction : String -> Maybe Instruction
parseInstruction s =
  case words s of
    ["mask","=",v] => SetMask <$> parseMask v
    [i,"=",v] => SetMem <$> (surrounded "mem[" "]" i >>= parseInteger) <*> parseInteger v
    _ => Nothing

runInstruction1 : State -> Instruction -> State
runInstruction1 s (SetMask m) = record { mask = m } s
runInstruction1 s (SetMem i v) =
  record { memory $= insert i (applyMask s.mask v) } s

runInstruction2 : State -> Instruction -> State
runInstruction2 s (SetMask m) = record { mask = m } s
runInstruction2 s (SetMem i v) =
  let js = applyMaskIndex s.mask i
      memory' = foldl (\m, j => insert j v m) s.memory js
  in record { memory = memory' } s

main : IO ()
main = do
  instructions <- parseLines parseInstruction
  let sumWith = (\f => sum $ .memory $ foldl f state0 instructions)
  putStr "*   "; printLn (sumWith runInstruction1)
  putStr "**  "; printLn (sumWith runInstruction2)


import Data.List

%default total

data WareAction = CreateNew | UpdateExist | RemoveExist | GetWareInfo

implementation Eq WareAction where
  (==) CreateNew   CreateNew   = True
  (==) UpdateExist UpdateExist = True
  (==) RemoveExist RemoveExist = True
  (==) GetWareInfo GetWareInfo = True
  (==) _           _           = False

implementation DecEq WareAction where
  decEq wa1 wa2 =
    case wa1 == wa2 of
      False => Yes theyEqual
      True  => No theyNotEqual
    where
      theyEqual : wa1 = wa2
      theyEqual = really_believe_me (Refl {x = wa1})
      theyNotEqual : wa1 = wa2 -> Void
      theyNotEqual prf = believe_me {b = Void} ()

record Ware where
  constructor MkWare
  name: String
  price: Double

data Role = SuperUser | Operator | Guest

roleToActions : Role -> List WareAction
roleToActions SuperUser = CreateNew :: UpdateExist :: RemoveExist :: GetWareInfo :: Nil
roleToActions Operator  = CreateNew :: UpdateExist :: GetWareInfo :: Nil
roleToActions Guest     = GetWareInfo :: Nil

record User where
  constructor MkUser
  firstName: String
  secondName: String
  role: Role

userActions : User -> List WareAction
userActions = roleToActions . role

checkUserRights: (user: User) -> (reqAction: WareAction) -> Bool
checkUserRights user reqAction =
  let
    userActions = roleToActions(role user)
  in
    any (\action => action == reqAction) userActions

ActionResult: Type
ActionResult = Either String Ware

createNewWare: (name: String) -> (price: Double) -> (user: User) -> ActionResult
createNewWare name price user = case checkUserRights user CreateNew of
  False => Left  ("Have no rights")
  True  => Right (MkWare name price)

HasAccess : (user: User) -> (action: WareAction) -> Type
HasAccess user action = Elem action (userActions user)

data ContainsAccess: User -> WareAction -> Type where
  Positive: (user: User) -> (action: WareAction) -> Elem action (userActions user) -> ContainsAccess user action

proveNegative : (contra : Elem req (userActions user) -> Void) -> ContainsAccess user req -> Void
proveNegative contra (Positive user req prf) = contra prf

proveContainsAccess: (user: User) -> (req: WareAction) -> Dec (ContainsAccess user req)
proveContainsAccess user req =
  case isElem req (userActions user) of
    (Yes prf) => Yes (Positive user req prf)
    (No contra) => No (proveNegative contra)

proveUserRights: (userActions: List WareAction) -> (req: WareAction) -> Dec(Elem req userActions)
proveUserRights userActions req = isElem req userActions

proveUserAccess: (user: User) -> (req: WareAction) -> Dec (HasAccess user req)
proveUserAccess user req = proveUserRights (roleToActions(role user)) req

createProved: (user: User) -> (prf: ContainsAccess user CreateNew) -> Ware
createProved user (Positive user CreateNew x) = ?createProved_rhs_1

testGuest: User
testGuest = MkUser "Test" "Guest" Guest

testSuperUser: User
testSuperUser = MkUser "Test" "SuperUser" SuperUser

guestCreatesWare: ActionResult
guestCreatesWare = createNewWare "Test Ware" 10.0 testGuest

superUserCreatesWare: ActionResult
superUserCreatesWare = createNewWare "Test Ware" 10.0 testSuperUser


module Main

import Data.Vect

Relation : (tys : Vect arity Type) -> Type
Relation [] = Type
Relation (ty :: tys) = ty -> Relation tys

RelationOn : (ty : Type) -> (arity : Nat) -> Type
RelationOn ty arity = Relation $ replicate arity ty

data Chan : (a : Type) -> Type where
     MkChan : (ty0 : Type) -> (ty1 : Type) -> Chan (Relation [ty0, ty1])

data Cat : Type where
     MkCat : {o : Type} ->
             {a : Type} ->
             ((Relation [a, o]), (Relation [a, o]), (Relation [o, a]), (Relation [(a,a), o])) -> Cat

     MkCat2 : {o : Type} ->
              {a : Type} ->
              (a -> o, a -> o, a -> a, (a, a) -> o) -> Cat

add : Int -> Int
add x = x + 1


-- examples in "Type-Driven Development with Idris"
-- chapter 11, section 3, part 2

import Data.Primitives.Views
import System

-- check that all functions are total
%default total

randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
                (seed' `shiftR` 2) :: randoms seed'

arithInputs : Int -> Stream Int
arithInputs seed = map bound (randoms seed)
  where
    bound : Int -> Int
    bound num with (divides num 12)
      bound ((12 * div) + rem) | (DivBy prf) = rem + 1

data LazyFuel = LDry | LMore (Lazy LazyFuel)

partial
forever : LazyFuel
forever = LMore forever

data Command : Type -> Type where
  PutStr : String -> Command ()
  GetLine : Command String

data ConsoleIO : Type -> Type where
  Quit : a -> ConsoleIO a
  Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b

(>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
(>>=) = Do

runCommand : Command a -> IO a
runCommand (PutStr x) = putStr x
runCommand (GetLine) = getLine

run : LazyFuel -> ConsoleIO a -> IO (Maybe a)
run _ (Quit value) = pure $ Just value
run LDry (Do act gen) = pure Nothing
run (LMore fuel) (Do act gen) = do res <- runCommand act
                                   run fuel $ gen res

quiz' : Stream Int -> (score : Nat) -> ConsoleIO Nat
quiz'  (num1 :: num2 :: nums) score
 = do PutStr ("Score so far:" ++ show score ++ "\n")
      PutStr (show num1 ++ " * " ++ show num2 ++ "? ")
      answer <- GetLine
      if toLower answer == "quit" then Quit score else
        if cast answer == num1 * num2
          then do PutStr "Correct!\n"
                  quiz' nums (score + 1)
          else do PutStr ("Wrong, the answer is " ++ show (num1 * num2) ++ "\n")
                  quiz' nums score

partial
main' : IO ()
main' = do seed <- time
           Just score <- run forever (quiz' (arithInputs (fromInteger seed)) 0)
              | Nothing => putStrLn "Ran out of fuel"
           putStrLn $ "Final score: " ++ show score

mutual
  correct : Stream Int -> (score : Nat) -> ConsoleIO Nat
  correct nums score
    = do PutStr "Correct!\n"
         quiz nums (score + 1)

  wrong : Stream Int -> Int -> (score : Nat) -> ConsoleIO Nat
  wrong nums ans score
    = do PutStr $ "Wrong, the answer is " ++ show ans ++ "\n"
         quiz nums score

  quiz : Stream Int -> (score : Nat) -> ConsoleIO Nat
  quiz  (num1 :: num2 :: nums) score
  = do PutStr ("Score so far:" ++ show score ++ "\n")
       PutStr (show num1 ++ " * " ++ show num2 ++ "? ")
       answer <- GetLine
       if toLower answer == "quit" then Quit score else
         if cast answer == num1 * num2
           then correct nums score
           else wrong nums (num1 * num2) score

partial
main : IO ()
main = do seed <- time
          Just score <- run forever (quiz (arithInputs (fromInteger seed)) 0)
            | Nothing => putStrLn "Ran out of fuel"
          putStrLn $ "Final score: " ++ show score


{-
<
=
>
6
2
8
-}

instance Show Ordering where
  show LT = "<"
  show GT = ">"
  show EQ = "="

test : Ord a => a -> a -> IO ()
test x y = printLn $ compare x y

l : List (Int, Int)
l = [(33, 42), (42, 42), (42, 33)]

main : IO ()
main = do
  traverse_ (uncurry test) l
  traverse_ (\op => printLn $ 4 `op` 2) [(+), (-), (*)]


module Accumulate

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


module Main

triples : Int -> List (Int, Int, Int)
triples top = [(x,y,z) | z<-[1..top], y<-[1..z], x<-[1..y],
                         x * x + y * y == z * z ]

main : IO ()
main = do putStrLn "Max: "
          max <- getLine
          printLn (triples (cast max))


mid : {A:Type} -> A -> A
mid = \ x => x

CPair : Type -> Type -> Type
CPair = \ a, b => (p : Type) -> (a -> b -> p) -> p

cdup : {A:Type} -> A -> CPair A A
cdup = \ a, x, p => p a a

CNat : Type
CNat = (n : Type) -> (n -> n) -> n -> n

czero : CNat
czero = \ n, s, z => z

csuc : CNat -> CNat
csuc = \ a, n, s, z => s (a n s z)

CVec : Type -> CNat -> Type
CVec = \ a, n => (V : CNat -> Type) -> ({n : CNat} -> a -> V n -> V (csuc n)) -> V czero -> V n

cnil : {A:Type} -> CVec A Main.czero
cnil = \ v, c, n => n

ccons : {A:Type}->{n:CNat} -> A -> CVec A n -> CVec A (csuc n)
ccons = \ a, as, v, c, n => c a (as v c n)

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

-- fails
-- idTest : {A:Type} -> A -> A
-- idTest =
--     mid mid mid mid mid mid mid mid mid mid mid mid mid mid mid mid mid mid mid mid
--     mid mid mid mid mid mid mid mid mid mid mid mid mid mid mid mid mid mid mid mid

-- fails
-- pairTest =
--   let x0  = cdup Type
--       x1  = cdup x0
--       x2  = cdup x1
--       x3  = cdup x2
--       x4  = cdup x3
--       x5  = cdup x4
--       x6  = cdup x5
--       x7  = cdup x6
--       x8  = cdup x7
--       x9  = cdup x8
--       x10 = cdup x9
--       x11 = cdup x10
--       x12 = cdup x11
--       x13 = cdup x12
--       x14 = cdup x13
--       x15 = cdup x14
--       x16 = cdup x15
--       x17 = cdup x16
--       x18 = cdup x17
--       x19 = cdup x18
--       x20 = cdup x19
--       x21 = cdup x20
--       x22 = cdup x21
--       x23 = cdup x22
--       x24 = cdup x23
--       x25 = cdup x24
--       x26 = cdup x25
--       x27 = cdup x26
--       x28 = cdup x27
--       x29 = cdup x28
--       x30 = cdup x29
--   in x30

vecTest : Type
vecTest =
  let foo =
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type
       (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type (ccons Type

       cnil

       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))
       ))))))))))))))))))))))))))))))

  in Type


module Data.Nat.Factor

import Control.WellFounded
import Data.Fin
import Data.Fin.Extra
import Data.Nat
import Data.Nat.Equational
import Syntax.PreorderReasoning

%default total

||| Factor n p is a witness that p is indeed a factor of n,
||| i.e. there exists a q such that p * q = n.
public export
data Factor : Nat -> Nat -> Type where
    CofactorExists : {p, n : Nat} -> (q : Nat) -> n = p * q -> Factor p n

||| NotFactor n p is a witness that p is NOT a factor of n,
||| i.e. there exist a q and an r, greater than 0 but smaller than p,
||| such that p * q + r = n.
public export
data NotFactor : Nat -> Nat -> Type where
    ZeroNotFactorS : (n : Nat) -> NotFactor Z (S n)
    ProperRemExists : {p, n : Nat} -> (q : Nat) ->
        (r : Fin (pred p)) ->
        n = p * q + S (finToNat r) ->
        NotFactor p n

||| DecFactor n p is a result of the process which decides
||| whether or not p is a factor on n.
public export
data DecFactor : Nat -> Nat -> Type where
    ItIsFactor : Factor p n -> DecFactor p n
    ItIsNotFactor : NotFactor p n -> DecFactor p n

||| CommonFactor n m p is a witness that p is a factor of both n and m.
public export
data CommonFactor : Nat -> Nat -> Nat -> Type where
    CommonFactorExists : {a, b : Nat} -> (p : Nat) -> Factor p a -> Factor p b -> CommonFactor p a b

||| GCD n m p is a witness that p is THE greatest common factor of both n and m.
||| The second argument to the constructor is a function which for all q being
||| a factor of both n and m, proves that q is a factor of p.
|||
||| This is equivalent to a more straightforward definition, stating that for
||| all q being a factor of both n and m, q is less than or equal to p, but more
||| powerful and therefore more useful for further proofs. See below for a proof
||| that if q is a factor of p then q must be less than or equal to p.
public export
data GCD : Nat -> Nat -> Nat -> Type where
    MkGCD : {a, b, p : Nat} ->
        {auto notBothZero : NotBothZero a b} ->
        (CommonFactor p a b) ->
        ((q : Nat) -> CommonFactor q a b -> Factor q p) ->
        GCD p a b

Uninhabited (Factor Z (S n)) where
    uninhabited (CofactorExists q prf) = uninhabited prf

||| Given a statement that p is factor of n, return its cofactor.
export
cofactor : Factor p n -> (q : Nat ** Factor q n)
cofactor (CofactorExists q prf) =
        (q ** CofactorExists p $ rewrite multCommutative q p in prf)

||| 1 is a factor of any natural number.
export
oneIsFactor : (n : Nat) -> Factor 1 n
oneIsFactor Z = CofactorExists Z Refl
oneIsFactor (S k) = CofactorExists (S k) (rewrite plusZeroRightNeutral k in Refl)

||| 1 is the only factor of itself
export
oneSoleFactorOfOne : (a : Nat) -> Factor a 1 -> a = 1
oneSoleFactorOfOne 0 (CofactorExists _ prf) = sym prf
oneSoleFactorOfOne 1 _ = Refl
oneSoleFactorOfOne (S (S k)) (CofactorExists Z prf) =
  absurd . uninhabited $ trans prf $ multCommutative k 0
oneSoleFactorOfOne (S (S k)) (CofactorExists (S j) prf) =
  absurd . uninhabited $
    trans
      (succInjective 0 (j + S (j + (k * S j))) prf)
      (plusCommutative j (S (j + (k * S j))))

||| Every natural number is factor of itself.
export
Reflexive Nat Factor where
  reflexive = CofactorExists 1 $ rewrite multOneRightNeutral x in Refl

||| Factor relation is transitive. If b is factor of a and c is b factor of c
||| is also a factor of a.
export
Transitive Nat Factor where
  transitive (CofactorExists qb prfAB) (CofactorExists qc prfBC) =
    CofactorExists (qb * qc) $
        rewrite prfBC in
        rewrite prfAB in
        rewrite multAssociative x qb qc in
        Refl

export
Preorder Nat Factor where

multOneSoleNeutral : (a, b : Nat) -> S a = S a * b -> b = 1
multOneSoleNeutral Z b prf =
        rewrite sym $ plusZeroRightNeutral b in
        sym prf
multOneSoleNeutral (S k) Z prf =
        absurd . uninhabited $ trans prf $ multCommutative k 0
multOneSoleNeutral (S k) (S Z) prf = Refl
multOneSoleNeutral (S k) (S (S j)) prf =
        absurd . uninhabited .
        subtractEqLeft k {c = S j + S (j + (k * S j))} $
        rewrite plusSuccRightSucc j (S (j + (k * S j))) in
        rewrite plusZeroRightNeutral k in
        rewrite plusAssociative k j (S (S (j + (k * S j)))) in
        rewrite sym $ plusCommutative j k in
        rewrite sym $ plusAssociative j k (S (S (j + (k * S j)))) in
        rewrite sym $ plusSuccRightSucc k (S (j + (k * S j))) in
        rewrite sym $ plusSuccRightSucc k (j + (k * S j)) in
        rewrite plusAssociative k j (k * S j) in
        rewrite plusCommutative k j in
        rewrite sym $ plusAssociative j k (k * S j) in
        rewrite sym $ multRightSuccPlus k (S j) in
        succInjective k (j + (S (S (j + (k * (S (S j))))))) $
        succInjective (S k) (S (j + (S (S (j + (k * (S (S j)))))))) prf

||| If a is a factor of b and b is a factor of a, then a = b.
public export
Antisymmetric Nat Factor where
  antisymmetric {x = Z} (CofactorExists _ prfAB) _ = sym prfAB
  antisymmetric {y = Z} _ (CofactorExists _ prfBA) = prfBA
  antisymmetric {x = S a} {y = S _} (CofactorExists qa prfAB) (CofactorExists qb prfBA) =
      let qIs1 = multOneSoleNeutral a (qa * qb) $
              rewrite multAssociative (S a) qa qb in
              rewrite sym prfAB in
              prfBA
      in
      rewrite prfAB in
      rewrite oneSoleFactorOfOne qa . CofactorExists qb $ sym qIs1 in
      rewrite multOneRightNeutral a in
      Refl

PartialOrder Nat Factor where

||| No number can simultaneously be and not be a factor of another number.
export
factorNotFactorAbsurd : Factor p n -> Not (NotFactor p n)
factorNotFactorAbsurd (CofactorExists _ prf) (ZeroNotFactorS _) =
        uninhabited prf
factorNotFactorAbsurd (CofactorExists q prf) (ProperRemExists q' r contra) with (cmp q q')
    factorNotFactorAbsurd (CofactorExists q prf) (ProperRemExists (q + S d) r contra) | CmpLT d =
        SIsNotZ .
        subtractEqLeft (p * q) {b = S ((p * S d) + finToNat r)} $
        rewrite plusZeroRightNeutral (p * q) in
        rewrite plusSuccRightSucc (p * S d) (finToNat r) in
        rewrite plusAssociative (p * q) (p * S d) (S (finToNat r)) in
        rewrite sym $ multDistributesOverPlusRight p q (S d) in
        rewrite sym contra in
        rewrite sym prf in
        Refl
    factorNotFactorAbsurd (CofactorExists q prf) (ProperRemExists q r contra) | CmpEQ =
      SIsNotZ $ sym $
        plusLeftCancel (p * q) 0 (S (finToNat r)) $
          trans (plusZeroRightNeutral (p * q)) $
            trans (sym prf) contra
    factorNotFactorAbsurd (CofactorExists (q + S d) prf) (ProperRemExists q r contra) | CmpGT d =
        let srEQpPlusPD = the (p + (p * d) = S (finToNat r)) $
                rewrite sym $ multRightSuccPlus p d in
                subtractEqLeft (p * q) $
                    rewrite sym $ multDistributesOverPlusRight p q (S d) in
                    rewrite sym contra in
                    sym prf
        in
        case p of
            Z => uninhabited srEQpPlusPD
            (S k) =>
                succNotLTEzero .
                subtractLteLeft k {b = S (d + (k * d))} $
                rewrite sym $ plusSuccRightSucc k (d + (k * d)) in
                rewrite plusZeroRightNeutral k in
                rewrite srEQpPlusPD in
                elemSmallerThanBound r

||| Anything is a factor of 0.
export
anythingFactorZero : (a : Nat) -> Factor a 0
anythingFactorZero a = CofactorExists 0 (sym $ multZeroRightZero a)

||| For all natural numbers p and q, p is a factor of (p * q).
export
multFactor : (p, q : Nat) -> Factor p (p * q)
multFactor p q = CofactorExists q Refl

||| If n > 0 then any factor of n must be less than or equal to n.
export
factorLteNumber : Factor p n -> {auto positN : LTE 1 n} -> LTE p n
factorLteNumber (CofactorExists Z prf) =
        let nIsZero = trans prf $ multCommutative p 0
            oneLteZero = replace {p = LTE 1} nIsZero positN
        in
        absurd $ succNotLTEzero oneLteZero
factorLteNumber (CofactorExists (S k) prf) =
        rewrite prf in
        leftFactorLteProduct p k

||| If p is a factor of n, then it is also a factor of (n + p).
export
plusDivisorAlsoFactor : Factor p n -> Factor p (n + p)
plusDivisorAlsoFactor (CofactorExists q prf) =
        CofactorExists (S q) $
            rewrite plusCommutative n p in
            rewrite multRightSuccPlus p q in
            cong (plus p) prf

||| If p is NOT a factor of n, then it also is NOT a factor of (n + p).
export
plusDivisorNeitherFactor : NotFactor p n -> NotFactor p (n + p)
plusDivisorNeitherFactor (ZeroNotFactorS k) =
        rewrite plusZeroRightNeutral k in
        ZeroNotFactorS k
plusDivisorNeitherFactor (ProperRemExists q r remPrf) =
        ProperRemExists (S q) r $
            rewrite multRightSuccPlus p q in
            rewrite sym $ plusAssociative p (p * q) (S $ finToNat r) in
            rewrite plusCommutative p ((p * q) + S (finToNat r)) in
            rewrite remPrf in
            Refl

||| If p is a factor of n, then it is also a factor of any multiply of n.
export
multNAlsoFactor : Factor p n -> (a : Nat) -> {auto aok : LTE 1 a} -> Factor p (n * a)
multNAlsoFactor _ Z = absurd $ succNotLTEzero aok
multNAlsoFactor (CofactorExists q prf) (S a) =
        CofactorExists (q * S a) $
            rewrite prf in
            sym $ multAssociative p q (S a)

||| If p is a factor of both n and m, then it is also a factor of their sum.
export
plusFactor : Factor p n -> Factor p m -> Factor p (n + m)
plusFactor (CofactorExists qn prfN) (CofactorExists qm prfM) =
        rewrite prfN in
        rewrite prfM in
        rewrite sym $ multDistributesOverPlusRight p qn qm in
        multFactor p (qn + qm)

||| If p is a factor of a sum (n + m) and a factor of n, then it is also
||| a factor of m. This could be expressed more naturally with minus, but
||| it would be more difficult to prove, since minus lacks certain properties
||| that one would expect from decent subtraction.
export
minusFactor : {b : Nat} -> Factor p (a + b) -> Factor p a -> Factor p b
minusFactor (CofactorExists qab prfAB) (CofactorExists qa prfA) =
        CofactorExists (minus qab qa) $
            rewrite multDistributesOverMinusRight p qab qa in
            rewrite sym prfA in
            rewrite sym prfAB in
            replace {p = \x => b = minus (a + b) x} (plusZeroRightNeutral a) $
            rewrite plusMinusLeftCancel a b 0 in
            rewrite minusZeroRight b in
            Refl

||| A decision procedure for whether of not p is a factor of n.
export
decFactor : (n, d : Nat) -> DecFactor d n
decFactor Z Z = ItIsFactor $ reflexive {x = Z}
decFactor (S k) Z = ItIsNotFactor $ ZeroNotFactorS k
decFactor n (S d) =
        let Fraction n (S d) q r prf = Data.Fin.Extra.divMod n (S d) in
        case r of
            FZ =>
              ItIsFactor $ CofactorExists q $
                rewrite sym prf in
                  rewrite plusCommutative (q * (S d)) 0 in
                    multCommutative q (S d)

            (FS pr) =>
                ItIsNotFactor $ ProperRemExists q pr (
                        rewrite multCommutative d q in
                        rewrite sym $ multRightSuccPlus q d in
                        sym prf
                    )

||| For all p greater than 1, if p is a factor of n, then it is NOT a factor
||| of (n + 1).
export
factNotSuccFact : {p : Nat} -> GT p 1 -> Factor p n -> NotFactor p (S n)
factNotSuccFact {p = Z} pGt1 (CofactorExists q prf) =
        absurd $ succNotLTEzero pGt1
factNotSuccFact {p = S Z} pGt1 (CofactorExists q prf) =
        absurd . succNotLTEzero $ fromLteSucc pGt1
factNotSuccFact {p = S (S k)} pGt1 (CofactorExists q prf) =
        ProperRemExists q FZ (
            rewrite sym prf in
            rewrite plusCommutative n 1 in
            Refl
        )

using (p : Nat)
  ||| The relation of common factor is symmetric, that is if p is a
  ||| common factor of n and m, then it is also a common factor of
  ||| m and n.
  public export
  Symmetric Nat (CommonFactor p) where
    symmetric (CommonFactorExists p pfx pfy) = CommonFactorExists p pfy pfx

  ||| The relation of greatest common divisor is symmetric.
  public export
  Symmetric Nat (GCD p) where
    symmetric {x = Z} {y = Z} (MkGCD _ _) impossible
    symmetric {x = S _} (MkGCD cf greatest) =
            MkGCD (symmetric {ty = Nat} cf) $
            \q, cf => greatest q (symmetric {ty = Nat} cf)
    symmetric {y = S _} (MkGCD cf greatest) =
            MkGCD (symmetric {ty = Nat} cf) $
            \q, cf => greatest q (symmetric {ty = Nat} cf)

||| If p is a common factor of a and b, then it is also a factor of their GCD.
||| This actually follows directly from the definition of GCD.
export
commonFactorAlsoFactorOfGCD : {p : Nat} -> Factor p a -> Factor p b -> GCD q a b -> Factor p q
commonFactorAlsoFactorOfGCD pfa pfb (MkGCD _ greatest) =
        greatest p (CommonFactorExists p pfa pfb)

||| 1 is a common factor of any pair of natural numbers.
export
oneCommonFactor : (a, b : Nat) -> CommonFactor 1 a b
oneCommonFactor a b = CommonFactorExists 1
        (CofactorExists a (rewrite plusZeroRightNeutral a in Refl))
        (CofactorExists b (rewrite plusZeroRightNeutral b in Refl))

||| Any natural number is a common factor of itself and itself.
export
selfIsCommonFactor : (a : Nat) -> {auto ok : LTE 1 a} -> CommonFactor a a a
selfIsCommonFactor a =
  let prf = reflexive {x = a} in
    CommonFactorExists a prf prf

-- Some helpers for the gcd function.
data Search : Type where
    SearchArgs : (a, b : Nat) -> LTE b a -> {auto bNonZero : LTE 1 b} -> Search

left : Search -> Nat
left (SearchArgs l _ _) = l

right : Search -> Nat
right (SearchArgs _ r _) = r

Sized Search where
    size (SearchArgs a b _) = a + b

notLteAndGt : (a, b : Nat) -> LTE a b -> Not (GT a b)
notLteAndGt Z _ _ aGtB = succNotLTEzero aGtB
notLteAndGt (S _) Z aLteB _ = succNotLTEzero aLteB
notLteAndGt (S k) (S j) aLteB aGtB = notLteAndGt k j (fromLteSucc aLteB) (fromLteSucc aGtB)

gcd_step : (x : Search) ->
           (rec : (y : Search) -> Smaller y x ->
                  (f : Nat ** GCD f (left y) (right y))) ->
           (f : Nat ** GCD f (left x) (right x))
gcd_step (SearchArgs Z _ bLteA {bNonZero}) _ = absurd . succNotLTEzero $ transitive {ty = Nat} bNonZero bLteA
gcd_step (SearchArgs _ Z _ {bNonZero}) _ = absurd $ succNotLTEzero bNonZero
gcd_step (SearchArgs (S a) (S b) bLteA) rec =
  case divMod (S a) (S b) of
    Fraction (S a) (S b) q FZ prf =>
        let sbIsFactor =
                rewrite multCommutative b q in
                rewrite sym $ multRightSuccPlus q b in
                replace {p = \x => S a = x} (plusZeroRightNeutral (q * S b)) $ sym prf
            skDividesA = CofactorExists q sbIsFactor
            skDividesB = reflexive {x = S b}
        in
        (S b ** MkGCD (CommonFactorExists (S b) skDividesA skDividesB)
                      (\q', (CommonFactorExists q' _ qfb) => qfb))

    Fraction (S a) (S b) q (FS r) prf =>
            let rLtSb = lteSuccRight $ elemSmallerThanBound r
                _ = the (LTE 1 q) $ case q of
                    Z => absurd . notLteAndGt (S $ finToNat r) b (elemSmallerThanBound r) $
                        replace {p = LTE (S b)} (sym prf) bLteA
                    (S k) => LTESucc LTEZero
                (f ** MkGCD (CommonFactorExists f prfSb prfRem) greatestSbSr) =
                    rec (SearchArgs (S b) (S $ finToNat r) rLtSb) $
                      rewrite plusCommutative a (S b) in
                        LTESucc . LTESucc . plusLteLeft b . fromLteSucc $
                          transitive {rel = LTE} (elemSmallerThanBound $ FS r) bLteA

                prfSa =
                    rewrite sym prf in
                    rewrite multCommutative q (S b) in
                    plusFactor (multNAlsoFactor prfSb q) prfRem
                greatest = the
                    ((q' : Nat) -> CommonFactor q' (S a) (S b) -> Factor q' f)
                    (\q', (CommonFactorExists q' qfa qfb) =>
                        let sbfqSb =
                                rewrite multCommutative q (S b) in
                                multFactor (S b) q
                            rightPrf = minusFactor {a = q * S b}
                                (rewrite prf in qfa)
                                (transitive {ty = Nat} qfb sbfqSb)
                        in
                        greatestSbSr q' (CommonFactorExists q' qfb rightPrf)
                    )
            in
            (f ** MkGCD (CommonFactorExists f prfSa prfSb) greatest)

||| An implementation of Euclidean Algorithm for computing greatest common
||| divisors. It is proven correct and total; returns a proof that computed
||| number actually IS the GCD. Unfortunately it's very slow, so improvements
||| in terms of efficiency would be welcome.
export
gcd : (a, b : Nat) -> {auto ok : NotBothZero a b} -> (f : Nat ** GCD f a b)
gcd Z Z impossible
gcd Z b =
    (b ** MkGCD (CommonFactorExists b (anythingFactorZero b) (reflexive {x = b})) $
        \q, (CommonFactorExists q _ prf) => prf
    )
gcd a Z =
    (a ** MkGCD (CommonFactorExists a (reflexive {x = a}) (anythingFactorZero a)) $
        \q, (CommonFactorExists q prf _) => prf
    )
gcd (S a) (S b) with (cmp (S a) (S b))
    gcd (S (b + S d)) (S b) | CmpGT d =
        sizeInd gcd_step $
          SearchArgs (S (b + S d)) (S b) $
            rewrite sym $ plusSuccRightSucc b d in
              LTESucc . lteSuccRight $ lteAddRight b

    gcd (S a) (S a)         | CmpEQ =
        (S a ** MkGCD (selfIsCommonFactor (S a))
                      (\q, (CommonFactorExists q qfa _) => qfa))

    gcd (S a) (S (a + S d)) | CmpLT d =
        let (f ** MkGCD prf greatest) =
              sizeInd gcd_step $
                SearchArgs (S (a + S d)) (S a) $
                  rewrite sym $ plusSuccRightSucc a d in
                    LTESucc . lteSuccRight $ lteAddRight a
        in
        (f ** MkGCD (symmetric {ty = Nat} prf)
                    (\q, cf => greatest q $ symmetric {ty = Nat} cf))

||| For every two natural numbers there is a unique greatest common divisor.
export
gcdUnique : GCD p a b -> GCD q a b -> p = q
gcdUnique (MkGCD pCFab greatestP) (MkGCD qCFab greatestQ) =
    antisymmetric (greatestQ p pCFab) (greatestP q qCFab)

divByGcdHelper : (a, b, c : Nat) -> GCD (S a) (S a * S b) (S a * c) -> GCD 1 (S b) c
divByGcdHelper a b c (MkGCD _ greatest) =
    MkGCD (CommonFactorExists 1 (oneIsFactor (S b)) (oneIsFactor c)) $
    \q, (CommonFactorExists q (CofactorExists qb prfQB) (CofactorExists qc prfQC)) =>
        let qFab = CofactorExists qb $
                rewrite multCommutative q (S a) in
                rewrite sym $ multAssociative (S a) q qb in
                rewrite sym $ prfQB in
                Refl
            qFac = CofactorExists qc $
                rewrite multCommutative q (S a) in
                rewrite sym $ multAssociative (S a) q qc in
                rewrite sym $ prfQC in
                Refl
            CofactorExists f prfQAfA =
                greatest (q * S a) (CommonFactorExists (q * S a) qFab qFac)
            qf1 = multOneSoleNeutral a (f * q) $
                rewrite multCommutative f q in
                rewrite multAssociative (S a) q f in
                rewrite sym $ multCommutative q (S a) in
                prfQAfA
        in
        CofactorExists f $
            rewrite multCommutative q f in
            sym qf1

||| For every two natural numbers, if we divide both of them by their GCD,
||| the GCD of resulting numbers will always be 1.
export
divByGcdGcdOne : {a, b, c : Nat} -> GCD a (a * b) (a * c) -> GCD 1 b c
divByGcdGcdOne {a = Z} (MkGCD _ _) impossible
divByGcdGcdOne {a = S a} {b = Z} {c = Z} (MkGCD {notBothZero} _ _) =
        case replace {p = \x => NotBothZero x x} (multZeroRightZero (S a)) notBothZero of
            LeftIsNotZero impossible
            RightIsNotZero impossible
divByGcdGcdOne {a = S a} {b = Z} {c = S c} gcdPrf@(MkGCD {notBothZero} _ _) =
        case replace {p = \x => NotBothZero x (S a * S c)} (multZeroRightZero (S a)) notBothZero of
            LeftIsNotZero impossible
            RightIsNotZero => symmetric {ty = Nat} $ divByGcdHelper a c Z $ symmetric {ty = Nat} gcdPrf
divByGcdGcdOne {a = S a} {b = S b} {c = Z} gcdPrf@(MkGCD {notBothZero} _ _) =
        case replace {p = \x => NotBothZero (S a * S b) x} (multZeroRightZero (S a)) notBothZero of
            RightIsNotZero impossible
            LeftIsNotZero => divByGcdHelper a b Z gcdPrf
divByGcdGcdOne {a = S a} {b = S b} {c = S c} gcdPrf =
        divByGcdHelper a b (S c) gcdPrf


module EffCont

data Exists : List a -> a -> Type where
    Here : Exists (x :: xs) x
    There : Exists xs x -> Exists (y :: xs) x

data Effect : List (Type -> Type) -> Type -> Type where
  Pure : a -> Effect xs a
  EffectC : {f : Type -> Type} -> Exists xs f -> f a -> Effect xs a

data Eff : List (Type -> Type) -> Type -> Type where
  Cont : ({r : Type} -> (a -> r) -> ({x : Type} -> Effect xs x -> (x -> r) -> r) -> r) -> Eff xs a

pure : a -> Eff xs a
pure x = Cont (\k, imp => imp (Pure x) k)

(>>=) : Eff xs a -> (a -> Eff xs b) -> Eff xs b
(>>=) (Cont g) f = Cont (\k, imp => g (\x => let (Cont g') = f x in g' k imp) imp)

-- State effect
data State : (s : Type) -> Type -> Type where
  Get : State s s
  Put : s -> State s ()

get : {auto e : Exists xs (State s)} -> Eff xs s
get {e} = Cont (\k, imp => imp (EffectC e Get) k)

put : {auto e : Exists xs (State s)} -> s -> Eff xs ()
put {e} s = Cont (\k, imp => imp (EffectC e (Put s)) k)

-- Reader effect
data Reader : (e : Type) -> Type -> Type where
  Ask : Reader e e

ask : {auto e : Exists xs (Reader en)} -> Eff xs en
ask {e} = Cont (\k, imp => imp (EffectC e Ask) k)

-- Interpreters
runPure : Effect [] x -> (x -> r) -> r
runPure (Pure x) k = k x
runPure (EffectC Here _) _ impossible
runPure (EffectC (There _) _) _ impossible

stateImp : State s x -> (x -> s -> r) -> s -> r
stateImp Get k st = k st st
stateImp (Put st') k st = k () st'

runState : (Effect xs x -> (x -> r) -> r) -> Effect (State s :: xs) x -> (x -> s -> r) -> s -> r
runState k (Pure x) k' = k' x
runState k (EffectC Here effect) k' = stateImp effect k'
runState k (EffectC (There xs) fa) k' = \st => k (EffectC xs fa) (\x => k' x st)

readerImp : Reader e x -> (x -> e -> r) -> e -> r
readerImp Ask k e = k e e

runReader : (Effect xs x -> (x -> r) -> r) -> Effect (Reader e :: xs) x -> (x -> e -> r) -> e -> r
runReader k (Pure x) k' = k' x
runReader k (EffectC Here effect) k' = readerImp effect k'
runReader k (EffectC (There xs) fa) k' = \e => k (EffectC xs fa) (\x => k' x e)

run : (a -> r) -> ({x : Type} -> Effect xs x -> (x -> r) -> r) -> Eff xs a -> r
run k imp (Cont f) = f k imp

example : Eff [State Int, Reader Int] Int
example = do s <- get
             put (s + 1)
             s <- get
             a <- ask
             pure (s + a)

test : (Int, Int, Int)
test = let f = run (\x, s, e => (x, s, e)) (\eff, k => runState (runReader runPure) eff k) example in f 1 2


module Verified.Functor.List

import Verified.Functor

instance VerifiedFunctor List where
  functorIdentity [] = Refl
  functorIdentity (x :: xs) =
    let IHxs = functorIdentity xs in ?lemma1
  functorComposition [] g1 g2 = Refl
  functorComposition (x :: xs) g1 g2 =
    let IHxs = functorComposition xs g1 g2 in ?lemma2

---------- Proofs ----------

Verified.Functor.List.lemma2 = proof
  intros
  rewrite IHxs
  exact Refl

Verified.Functor.List.lemma1 = proof
  intros
  rewrite IHxs
  exact Refl


module Data.Nat.Extra

import Data.Nat

public export
(-) : (m : Nat) -> (n : Nat) -> {auto smaller : LTE n m} -> Nat
(-) m n {smaller} = minus m n


module Data.SortedSet

import Data.Maybe
import Data.SortedMap

export
data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ())

export
empty : Ord k => SortedSet k
empty = SetWrapper Data.SortedMap.empty

export
insert : k -> SortedSet k -> SortedSet k
insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m)

export
delete : k -> SortedSet k -> SortedSet k
delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m)

export
contains : k -> SortedSet k -> Bool
contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m)

export
fromList : Ord k => List k -> SortedSet k
fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l))

export
toList : SortedSet k -> List k
toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)

export
Foldable SortedSet where
  foldr f e xs = foldr f e (Data.SortedSet.toList xs)

||| Set union. Inserts all elements of x into y
export
union : (x, y : SortedSet k) -> SortedSet k
union x y = foldr insert x y

||| Set difference. Delete all elments in y from x
export
difference : (x, y : SortedSet k) -> SortedSet k
difference x y = foldr delete x y

||| Set symmetric difference. Uses the union of the differences.
export
symDifference : (x, y : SortedSet k) -> SortedSet k
symDifference x y = union (difference x y) (difference y x)

||| Set intersection. Implemented as the difference of the union and the symetric difference.
export
intersection : (x, y : SortedSet k) -> SortedSet k
intersection x y = difference x (difference x y)

export
Ord k => Semigroup (SortedSet k) where
  (<+>) = union

export
Ord k => Monoid (SortedSet k) where
  neutral = empty

export
keySet : SortedMap k v -> SortedSet k
keySet = SetWrapper . map (const ())


-- -------------------------------------------------------------- [ Lens.idr ]
-- Description : Idris port of Control.Lens
-- Copyright   : (c) Huw Campbell
-- --------------------------------------------------------------------- [ EOH ]
module Control.Lens.Const
import Data.Contravariant

||| Const Functor.
public export
data Const : (0 a : Type) -> (b : Type) -> Type where
  MkConst: a -> Const a b

public export
getConst : Const a b -> a
getConst (MkConst x) = x

public export
Functor (Const a) where
  map _ (MkConst x) = (MkConst x)

public export
Contravariant (Const a) where
  contramap _ (MkConst x) = (MkConst x)

public export
implementation Monoid m => Applicative (Const m) where
  pure _                      = MkConst neutral
  (MkConst f) <*> (MkConst v) = MkConst (f <+> v)

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


module Data.Optics.Optional

||| Optional
data Optional s a =
  MkOptional (s -> Maybe a) (s -> a -> s)

%name Optional optional, optional1, optional2

get : (Optional s a) -> (s -> Maybe a)
get (MkOptional get set) = get

getOrModify: (Optional s a) -> s -> Either s a
getOrModify optional s' = case (get optional s') of
                          Just a' => Right a'
                          Nothing => Left s'

set : Optional s a -> s -> a -> s
set (MkOptional get set)  = set

--
-- Compositions
--

infixr 9 ?:+
||| compose two optionals
(?:+): Optional a b -> Optional s a -> Optional s b
(MkOptional get1 set1) ?:+ (MkOptional get2 set2) = MkOptional newGet newSet
  where
    newGet: s -> Maybe b
    newGet s = do a <- get2 s
                  b <- get1 a
                  return b

    newSet: s -> b -> s
    newSet s b = let a' = get2 s
                     newA = do a'' <- a'
                               return (set1 a'' b)
                     newS = case newA of
                              Just v => set2 s v
                              Nothing => s
                     in newS

infixr 9 +:?
(+:?) : Optional s a -> Optional a b -> Optional s b
(+:?) = flip (?:+)


||| Simple GADTs for F#
module Sg4f

%default total
%access public export

mutual
  ||| A term in the language
  ||| universe 0 - values
  ||| universe 1 - types
  ||| universe 2 - kinds
  ||| universe 2 - sorts
  data Term : (universe : Nat) -> Type where
    ||| A named term
    NamedTerm : Name u -> Term u
    ||| Function application
    Appl : (f : Func u t) -> (a : TypedTerm u t) -> Term u
    ||| Type constructor operator. Its terms cannot be values.
    Arrow : Term (S u) -> Term (S u) -> Term (S u)

  ||| A function term
  ||| Func is parameterized by the type of its input; thus, we must go down a
  ||| universe from its input to get its universe
  data Func : (universe : Nat) -> Term (S universe) -> Type where
    ||| The input and output type of the constructor
    Ctr : String -> (t : Term (S u)) -> Term (S u) -> Func u t

  data TypedTerm : (universe : Nat) -> Term (S universe) -> Type where
    TermWithType : (t : Term u) -> TypedTerm u (GetType t)

  ||| An actual name of a term
  data Name : (universe : Nat) -> Type where
    ||| The name of Type in any universe starting with 2 (since the lowest Type
    ||| has as its type Kind).
    Tau : Name (S (S n))
    ||| A primitive type or type constructor in universe one, opaque to the
    ||| source language because taken for granted as existing in the target
    ||| language. Syntax:
    |||   primitive string : Type
    |||   primitive Maybe : Type -> Type
    |||   primitive Either : Type -> Type -> Type
    ||| The term in universe two is the type of the primitive: all primitives
    ||| have a type of Type or of some type constructor, which are kinds, so it
    ||| is in universe two.
    PrimType : String -> Term 2 -> Name 1
    NamedFun : Func u t -> Name u

  ||| Get the type of some term. Returns a term in the next unvierse up.
  GetType : Term u -> Term (S u)
  GetType (NamedTerm Tau) = NamedTerm Tau
  GetType (NamedTerm (PrimType _ t)) = t
  GetType (NamedTerm (NamedFun (Ctr _ t x))) = Arrow t x
  GetType (Appl (Ctr _ _ z) _) = z
  GetType (Arrow x y) = NamedTerm Tau

funcName : Func u t -> String
funcName (Ctr x _ _) = x

||| Get the name of the type or type constructor
typeName : Name u -> String
typeName {u = (S (S Z))} Tau = "Type"
typeName {u = (S (S (S Z)))} Tau = "Kind"
typeName {u = (S (S (S (S Z))))} Tau = "Sort"
typeName {u = (S (S (S (S (S _)))))} Tau = "Why asketh thou such things?"
typeName (PrimType x _) = x
typeName (NamedFun f) = funcName f

Show (Term u) where
  show (NamedTerm x) = typeName x
  show (Appl f (TermWithType t)) = funcName f ++ " " ++ show t
  show (Arrow x y) = show x ++ " -> " ++ show y

showWithType : Term u -> String
showWithType t = show t ++ " : " ++ show (GetType t)


module Flexidisc.Validation

%default total
%access public export

data Validation e a = Error e | Valid a

ValidationL : (e, a :Type) -> Type
ValidationL e a = Validation (List e) a

implementation Functor (Validation e) where
  map func (Error x) = Error x
  map func (Valid x) = Valid (func x)

implementation Semigroup e => Applicative (Validation e) where
  pure x = Valid x
  (<*>) (Error x) (Error y) = Error (x <+> y)
  (<*>) (Error x) (Valid _) = Error x
  (<*>) (Valid _) (Error y) = Error y
  (<*>) (Valid f) (Valid x) = Valid (f x)

implementation (Show e, Show a) => Show (Validation e a) where
  show (Error x) = "❌ " <+> show x
  show (Valid x) = "✅ " <+> show x

export
validate : (a -> e) -> (a -> Bool) -> a -> Validation e a
validate err f x = if f x then Valid x else Error (err x)

export
validateL : (Applicative f, Semigroup (f e)) => (a -> e) -> (a -> Bool) -> a -> Validation (f e) a
validateL err f x = if f x then Valid x else Error (pure (err x))


f : (Int -> Bool) -> Int
f p = case (p 0, p 1) of
        (False, False) => 0
        (False, True)  => 1
        (True , False) => 2
        (True , True)  => 4

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

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

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