import Data.Vect

-- Chapter 3.2 Exercises

my_length : List a -> Nat
my_length [] = Z
my_length (x :: xs) = S (my_length xs)

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

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

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


import Data.IORef

count : Nat -> IORef Integer -> IO ()
count Z ref
    = do x <- readIORef ref
         printLn x
count (S k) ref
    = do modifyIORef ref (+1)
         count k ref

main : IO ()
main = do r <- newIORef 0
          count 100 r


module Prelude.EqOrd

import Builtin
import Prelude.Basics
import Prelude.Ops

%default total

------------------------
-- EQUALITY, ORDERING --
------------------------

||| The Eq interface defines inequality and equality.
public export
interface Eq ty where
  constructor MkEq
  (==) : ty -> ty -> Bool
  (/=) : ty -> ty -> Bool

  x == y = not (x /= y)
  x /= y = not (x == y)

public export
Eq Void where
  _ == _ impossible

public export
Eq () where
  _ == _ = True

public export
Eq Bool where
  True == True = True
  False == False = True
  _ == _ = False

public export
Eq Int where
  x == y = intToBool (prim__eq_Int x y)

public export
Eq Integer where
  x == y = intToBool (prim__eq_Integer x y)

public export
Eq Bits8 where
  x == y = intToBool (prim__eq_Bits8 x y)

public export
Eq Bits16 where
  x == y = intToBool (prim__eq_Bits16 x y)

public export
Eq Bits32 where
  x == y = intToBool (prim__eq_Bits32 x y)

public export
Eq Bits64 where
  x == y = intToBool (prim__eq_Bits64 x y)

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

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

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

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

public export
Eq Double where
  x == y = intToBool (prim__eq_Double x y)

public export
Eq Char where
  x == y = intToBool (prim__eq_Char x y)

public export
Eq String where
  x == y = intToBool (prim__eq_String x y)

public export
Eq a => Eq b => Eq (a, b) where
  (x1, y1) == (x2, y2) = x1 == x2 && y1 == y2

public export
data Ordering = LT | EQ | GT

public export
Eq Ordering where
  LT == LT = True
  EQ == EQ = True
  GT == GT = True
  _  == _  = False

||| The Ord interface defines comparison operations on ordered data types.
public export
interface Eq ty => Ord ty where
  constructor MkOrd
  compare : ty -> ty -> Ordering
  compare x y = if x < y then LT else if x == y then EQ else GT

  (<) : ty -> ty -> Bool
  (<) x y = compare x y == LT

  (>) : ty -> ty -> Bool
  (>) x y = compare x y == GT

  (<=) : ty -> ty -> Bool
  (<=) x y = compare x y /= GT

  (>=) : ty -> ty -> Bool
  (>=) x y = compare x y /= LT

  max : ty -> ty -> ty
  max x y = if x > y then x else y

  min : ty -> ty -> ty
  min x y = if (x < y) then x else y

export
comparing : Ord a => (b -> a) -> b -> b -> Ordering
comparing p x y = compare (p x) (p y)

public export
Ord Void where
  compare _ _ impossible

public export
Ord () where
  compare _ _ = EQ

public export
Ord Bool where
  compare False False = EQ
  compare False True = LT
  compare True False = GT
  compare True True = EQ

public export
Ord Int where
  (<) x y = intToBool (prim__lt_Int x y)
  (<=) x y = intToBool (prim__lte_Int x y)
  (>) x y = intToBool (prim__gt_Int x y)
  (>=) x y = intToBool (prim__gte_Int x y)

public export
Ord Integer where
  (<) x y = intToBool (prim__lt_Integer x y)
  (<=) x y = intToBool (prim__lte_Integer x y)
  (>) x y = intToBool (prim__gt_Integer x y)
  (>=) x y = intToBool (prim__gte_Integer x y)

-- Used for the nat hack
public export
compareInteger : (x, y : Integer) -> Ordering
compareInteger = compare

public export
Ord Bits8 where
  (<) x y = intToBool (prim__lt_Bits8 x y)
  (<=) x y = intToBool (prim__lte_Bits8 x y)
  (>) x y = intToBool (prim__gt_Bits8 x y)
  (>=) x y = intToBool (prim__gte_Bits8 x y)

public export
Ord Bits16 where
  (<) x y = intToBool (prim__lt_Bits16 x y)
  (<=) x y = intToBool (prim__lte_Bits16 x y)
  (>) x y = intToBool (prim__gt_Bits16 x y)
  (>=) x y = intToBool (prim__gte_Bits16 x y)

public export
Ord Bits32 where
  (<) x y = intToBool (prim__lt_Bits32 x y)
  (<=) x y = intToBool (prim__lte_Bits32 x y)
  (>) x y = intToBool (prim__gt_Bits32 x y)
  (>=) x y = intToBool (prim__gte_Bits32 x y)

public export
Ord Bits64 where
  (<) x y = intToBool (prim__lt_Bits64 x y)
  (<=) x y = intToBool (prim__lte_Bits64 x y)
  (>) x y = intToBool (prim__gt_Bits64 x y)
  (>=) x y = intToBool (prim__gte_Bits64 x y)

public export
Ord Int8 where
  (<) x y = intToBool (prim__lt_Int8 x y)
  (<=) x y = intToBool (prim__lte_Int8 x y)
  (>) x y = intToBool (prim__gt_Int8 x y)
  (>=) x y = intToBool (prim__gte_Int8 x y)

public export
Ord Int16 where
  (<) x y = intToBool (prim__lt_Int16 x y)
  (<=) x y = intToBool (prim__lte_Int16 x y)
  (>) x y = intToBool (prim__gt_Int16 x y)
  (>=) x y = intToBool (prim__gte_Int16 x y)

public export
Ord Int32 where
  (<) x y = intToBool (prim__lt_Int32 x y)
  (<=) x y = intToBool (prim__lte_Int32 x y)
  (>) x y = intToBool (prim__gt_Int32 x y)
  (>=) x y = intToBool (prim__gte_Int32 x y)

public export
Ord Int64 where
  (<) x y = intToBool (prim__lt_Int64 x y)
  (<=) x y = intToBool (prim__lte_Int64 x y)
  (>) x y = intToBool (prim__gt_Int64 x y)
  (>=) x y = intToBool (prim__gte_Int64 x y)

public export
Ord Double where
  (<) x y = intToBool (prim__lt_Double x y)
  (<=) x y = intToBool (prim__lte_Double x y)
  (>) x y = intToBool (prim__gt_Double x y)
  (>=) x y = intToBool (prim__gte_Double x y)

public export
Ord String where
  (<) x y = intToBool (prim__lt_String x y)
  (<=) x y = intToBool (prim__lte_String x y)
  (>) x y = intToBool (prim__gt_String x y)
  (>=) x y = intToBool (prim__gte_String x y)

public export
Ord Char where
  (<) x y = intToBool (prim__lt_Char x y)
  (<=) x y = intToBool (prim__lte_Char x y)
  (>) x y = intToBool (prim__gt_Char x y)
  (>=) x y = intToBool (prim__gte_Char x y)

public export
Ord a => Ord b => Ord (a, b) where
  compare (x1, y1) (x2, y2)
      = if x1 /= x2 then compare x1 x2
                    else compare y1 y2


module Data.Validated

import Data.List1

import Decidable.Equality

%default total

||| `Validated` is like an `Either` but accumulates all errors with semigroup operation.
public export
data Validated e a = Valid a | Invalid e

--- Instances of standard interfaces ---

public export
(Eq e, Eq a) => Eq (Validated e a) where
  Valid x   == Valid y   = x == y
  Invalid e == Invalid f = e == f
  _ == _ = False

export
(Show e, Show a) => Show (Validated e a) where
  showPrec d $ Valid   x = showCon d "Valid" $ showArg x
  showPrec d $ Invalid e = showCon d "Invalid" $ showArg e

public export
Functor (Validated e) where
  map f $ Valid x   = Valid $ f x
  map _ $ Invalid e = Invalid e

public export
Bifunctor Validated where
  bimap _ s $ Valid x   = Valid   $ s x
  bimap f _ $ Invalid e = Invalid $ f e

public export
Bifoldable Validated where
  bifoldr _ g acc (Valid a)   = g a acc
  bifoldr f _ acc (Invalid e) = f e acc

  bifoldl _ g acc (Valid a)   = g acc a
  bifoldl f _ acc (Invalid e) = f acc e

  binull _ = False

public export
Bitraversable Validated where
  bitraverse _ g (Valid a)   = Valid <$> g a
  bitraverse f _ (Invalid e) = Invalid <$> f e

||| Applicative composition preserves invalidity sequentially accumulating all errors.
public export
Semigroup e => Applicative (Validated e) where
  pure = Valid

  Valid f    <*> Valid x    = Valid $ f x
  Invalid e1 <*> Invalid e2 = Invalid $ e1 <+> e2
  Invalid e  <*> Valid _    = Invalid e
  Valid _    <*> Invalid e  = Invalid e

-- There is no `Monad` implementation because it can't be coherent with the accumulating `Applicative` one.

||| Semigroup operation selects the leftmost valid value.
||| If both sides are invalid, errors are accumulated.
public export
Semigroup e => Semigroup (Validated e a) where
  l@(Valid _) <+> _           = l
  _           <+> r@(Valid _) = r
  Invalid e1  <+> Invalid e2  = Invalid $ e1 <+> e2

public export
Monoid e => Monoid (Validated e a) where
  neutral = Invalid neutral

||| Alternative composition preserves validity selecting the leftmost valid value.
||| If both sides are invalid, errors are accumulated.
public export
Monoid e => Alternative (Validated e) where
  empty = neutral
  l@(Valid _) <|> _           = l
  _           <|> r@(Valid _) = r
  Invalid e1  <|> Invalid e2  = Invalid $ e1 <+> e2

public export
Foldable (Validated e) where
  foldr op init $ Valid x   = x `op` init
  foldr _  init $ Invalid _ = init

  foldl op init $ Valid x   = init `op` x
  foldl _  init $ Invalid _ = init

  null $ Valid _   = False
  null $ Invalid _ = True

public export
Traversable (Validated e) where
  traverse f $ Valid x   = Valid <$> f x
  traverse _ $ Invalid e = pure $ Invalid e

public export
Semigroup e => Zippable (Validated e) where
  zipWith f (Valid l)   (Valid r)   = Valid $ f l r
  zipWith _ (Valid _)   (Invalid r) = Invalid r
  zipWith _ (Invalid l) (Valid _)   = Invalid l
  zipWith _ (Invalid l) (Invalid r) = Invalid $ l <+> r

  zipWith3 f (Valid x)   (Valid y)   (Valid z)   = Valid $ f x y z
  zipWith3 _ (Valid _)   (Valid _)   (Invalid z) = Invalid z
  zipWith3 _ (Valid _)   (Invalid y) (Valid _)   = Invalid y
  zipWith3 _ (Valid _)   (Invalid y) (Invalid z) = Invalid $ y <+> z
  zipWith3 _ (Invalid x) (Valid _)   (Valid _)   = Invalid x
  zipWith3 _ (Invalid x) (Valid _)   (Invalid z) = Invalid $ x <+> z
  zipWith3 _ (Invalid x) (Invalid y) (Valid _)   = Invalid $ x <+> y
  zipWith3 _ (Invalid x) (Invalid y) (Invalid z) = Invalid $ x <+> y <+> z

  unzipWith f (Valid x)   = let (a, b) = f x in (Valid a, Valid b)
  unzipWith _ (Invalid e) = (Invalid e, Invalid e)

  unzipWith3 f (Valid x)   = let (a, b, c) = f x in (Valid a, Valid b, Valid c)
  unzipWith3 _ (Invalid e) = (Invalid e, Invalid e, Invalid e)

public export
Uninhabited (Valid x = Invalid e) where
  uninhabited Refl impossible

public export
Uninhabited (Invalid e = Valid x) where
  uninhabited Refl impossible

public export
(DecEq e, DecEq a) => DecEq (Validated e a) where
  decEq (Valid x) (Invalid y) = No uninhabited
  decEq (Invalid x) (Valid y) = No uninhabited
  decEq (Valid x) (Valid y) with (decEq x y)
    decEq (Valid _) (Valid _) | Yes p = rewrite p in Yes Refl
    decEq (Valid _) (Valid _) | No up = No $ \case Refl => up Refl
  decEq (Invalid x) (Invalid y) with (decEq x y)
    decEq (Invalid _) (Invalid _) | Yes p = rewrite p in Yes Refl
    decEq (Invalid _) (Invalid _) | No up = No $ \case Refl => up Refl

--- Convenience representations ---

||| Special case of `Validated` with a `List` as an error accumulator.
public export %inline
ValidatedL : Type -> Type -> Type
ValidatedL = Validated . List1

public export %inline
oneInvalid : Applicative f => e -> Validated (f e) a
oneInvalid = Invalid . pure

--- Conversions to and from `Either` ---

public export %inline
fromEither : Either e a -> Validated e a
fromEither $ Right x = Valid x
fromEither $ Left  e = Invalid e

public export %inline
fromEitherL : Either e a -> ValidatedL e a
fromEitherL $ Right x = Valid x
fromEitherL $ Left  e = oneInvalid e

public export %inline
toEither : Validated e a -> Either e a
toEither $ Valid   x = Right x
toEither $ Invalid e = Left e

--- Conversions to and from `Maybe` ---

public export %inline
fromMaybe : Monoid e => Maybe a -> Validated e a
fromMaybe $ Just x  = Valid x
fromMaybe $ Nothing = empty

public export %inline
toMaybe : Validated e a -> Maybe a
toMaybe $ Valid x   = Just x
toMaybe $ Invalid _ = Nothing

--- Property of being valid ---

public export
data IsValid : Validated e a -> Type where
  ItIsValid : IsValid $ Valid x

export
Uninhabited (IsValid $ Invalid e) where
  uninhabited ItIsValid impossible

public export
isItValid : (v : Validated e a) -> Dec (IsValid v)
isItValid $ Valid _   = Yes ItIsValid
isItValid $ Invalid _ = No absurd


module Main

h : Bool -> Nat
h False = r1 where
  r : Nat
  r = S Z
  r1 : Nat
  r1 = r
h True = r2 where
  r : Nat
  r = Z
  r2 : Nat
  r2 = r

main : IO ()
main = do printLn (h True); printLn (h False)


module Issue524

%logging totality 20

data Bad = MkBad (Not Bad)

hmmm : Bad -> Not Bad
hmmm (MkBad n) = n

ok : Not Bad
ok bad = hmmm bad bad

bad : Bad
bad = MkBad ok

total
ohno : Void
ohno = ok bad


%default total

data Tag =  A | B | C | Unknown | Unchecked

data Doutput : Tag -> Type where
  Ca : Doutput A
  Cb : Doutput B
  Cc : Doutput C
  Cu : Doutput Unknown
  Cs : String -> Doutput Unchecked

{- Based on output from database you construct type -}
typelevel : (a : Doutput Unchecked) -> Type
typelevel (Cs "A") = Doutput A
typelevel (Cs "B") = Doutput B
typelevel (Cs "C") = Doutput C
typelevel (Cs s) = Doutput Unknown

{- Check value takes a type of Doutput Unchecked and transforms into one the known or unknown file format -}
checkValue : (a : Doutput Unchecked) -> typelevel a
checkValue (Cs "A") = Ca
checkValue (Cs "B") = Cb
checkValue (Cs "C") = Cc
checkValue (Cs s) = ?Cu {- I am leaving it as meta variable beacause Idris is refusing to simplify it -}

{-

*Typefromdatabase> :r
Type checking ./Typefromdatabase.idr
Holes: Main.Cu1
*Typefromdatabase> ch
changeDir   check       checkValue  choice      choiceMap   chr
*Typefromdatabase> checkValue (Cs "A")
Ca : Doutput A
Holes: Main.Cu1
*Typefromdatabase> checkValue (Cs "B")
Cb : Doutput B
Holes: Main.Cu1
*Typefromdatabase> checkValue (Cs "C")
Cc : Doutput C
Holes: Main.Cu1
*Typefromdatabase> checkValue (Cs "Hello Wrold")
?Cu1 : Doutput Unknown
Holes: Main.Cu1
*Typefromdatabase>  -}


-- Write the signature of a function, typeNamed, that will take the name of a type and return that type. For example, typeNamed "Int" would return the type Int.
-- Implement your typeNamed function for a few different types.
-- Add the keyword total to the beginning of your typeNamed function signature from the Easy section—that is, total typeNamed : .... Reload your file, and see that your function is not total (defined for all inputs). Make your function total by giving it behavior for bad inputs such as "ThisIsNotAType".

total typeNamed : String -> Type
typeNamed "String" = String
typeNamed "Int" = Int
typeNamed _ = String


module Proofs.TranslationInvarianceTheory

import Common.Util
import Specifications.DiscreteOrderedGroup
import Proofs.GroupCancelationLemmas
import Proofs.GroupTheory
import Proofs.TranslationInvarianceTheory
import Proofs.DiscreteOrderTheory
import Symmetry.Opposite

%default total
%access export

infixl 8 #

rewriteBetween : a = c -> b = d -> Between leq (a,b) x -> Between leq (c,d) x
rewriteBetween p q given = rewrite sym p in rewrite sym q in given

weakenR : PartialOrderSpec rel ->
  rel b c -> Between rel (a,b) x -> Between rel (a,c) x
weakenR spec bc (MkBetween ax xb) =
  MkBetween ax (transitive spec _ _ _ xb bc)

invertBetween : PartiallyOrderedGroupSpec _ _ inv rel ->
  Between rel (a,b) x -> Between rel (inv b, inv a) (inv x)
invertBetween spec (MkBetween ax xb) =
  MkBetween (inverseReversesOrder spec xb)
            (inverseReversesOrder spec ax)

invertSymRange : PartiallyOrderedGroupSpec _ _ inv rel ->
  InSymRange rel inv b x -> InSymRange rel inv b (inv x)
invertSymRange {b} spec given = rewriteBetween Refl o2 o1 where
  o1 : Between rel (inv b, inv (inv b)) (inv x)
  o1 = invertBetween spec given
  o2 : inv (inv b) = b
  o2 = groupInverseInvolution (group spec) b

translateIntervalR : {(#) : Binop s} ->
  PartiallyOrderedMagmaSpec (#) leq -> (c : s) ->
    Between leq (a,b) x -> Between leq (a # c, b # c) (x # c)
translateIntervalR spec c (MkBetween ax xb) = MkBetween
  (translationInvariantR spec _ _ _ ax)
  (translationInvariantR spec _ _ _ xb)

translateIntervalL : {(#) : Binop s} ->
  PartiallyOrderedMagmaSpec (#) leq -> (c : s) ->
    Between leq (a,b) x -> Between leq (c # a, c # b) (c # x)
translateIntervalL spec = translateIntervalR (opposite spec)

composeIntervals : {(#) : Binop s} ->
  PartiallyOrderedMagmaSpec (#) leq ->
    Between leq (a,b) x ->
    Between leq (c,d) y ->
    Between leq (a # c, b # d) (x # y)
composeIntervals spec (MkBetween ax xb) (MkBetween cy yd) = MkBetween
  (composeOrder spec _ _ _ _ ax cy)
  (composeOrder spec _ _ _ _ xb yd)

addInSymRange : {(+) : Binop s} -> PartiallyOrderedGroupSpec (+) _ neg leq ->
  InSymRange leq neg a x ->
  InSymRange leq neg a y ->
  InSymRange leq neg (a + a) (x + y)
addInSymRange {a} spec p q =
  rewrite groupInverseAnti (group spec) a a in
  composeIntervals (invariantOrder spec) p q

public export
decideBetween : Decidable [s,s] leq => (a,b,x : s) -> Dec (Between leq (a,b) x)
decideBetween a b x =
  decideBoth MkBetween betweenL betweenR
    (decision {rel = leq} a x)
    (decision {rel = leq} x b)

public export
decidePivot : Decidable [s,s] leq =>
  DiscreteOrderedGroupSpec add zero neg leq unit ->
    (p,x : s) ->
    Between leq (a,b) x ->
    EitherErased (Between leq (a,p) x)
                 (Between leq (add unit p, b) x)
decidePivot {s} spec p x (MkBetween ax xb) =
  case separate spec x p of
    Left xp => Left (MkBetween ax xp)
    Right px => Right (MkBetween px xb)

public export
decidePivotBis : Decidable [s,s] leq =>
  DiscreteOrderedGroupSpec add zero neg leq unit ->
    (p,x : s) ->
    Between leq (a,b) x ->
    EitherErased (Between leq (a, add (neg unit) p) x)
                 (Between leq (p, b) x)
decidePivotBis {s} spec p x (MkBetween ax xb) =
  case separateBis spec x p of
    Left xp => Left (MkBetween ax xp)
    Right px => Right (MkBetween px xb)

public export
decidePartition3 : Decidable [s,s] leq =>
  DiscreteOrderedGroupSpec add zero neg leq unit ->
    (p,q,x : s) ->
    Between leq (a,b) x ->
    Either3Erased (Between leq (a,p) x)
                  (Between leq (add unit p, add (neg unit) q) x)
                  (Between leq (q,b) x)
decidePartition3 spec p q x axb =
  case decidePivot spec p x axb of
    Left l => Left l
    Right pxb =>
      case decidePivotBis spec q x pxb of
        Left m => Middle m
        Right r => Right r


module Sessions.Projection

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

import Data.List1

import Sessions.Meta

import Sessions.Global
import Sessions.Global.Involved

import Sessions.Local
import Sessions.Local.Same
import Sessions.Local.Same.All

import public Sessions.Projection.Error

%hide Data.List.merge

%default total

mutual

  namespace Term
    public export
    data Project : (tyHowMerge : {rs : List Ty}
                              -> {g  :      Ty}
                              -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                              -> (that  :                      Local typeR typeL typeM rs g)
                                       -> Type)
                -> (role  : typeR)
                -> (termG : Global typeR typeL typeM rs g)
                -> (termL : Local  typeR typeL typeM rs g)
                        -> Type
      where
        End : {merge : {rs    : List Ty}
                    -> {g     :      Ty}
                    -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                    -> (that  :                      Local typeR typeL typeM rs g)
                             -> Type}
                    -> Project merge whom End End

        Call : {merge : {rs    : List Ty}
                     -> {g     :      Ty}
                     -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                     -> (that  :                      Local typeR typeL typeM rs g)
                              -> Type}
                     -> Project merge whom (Call idx) (Call idx)

        Rec : {merge : {rs    : List Ty}
                    -> {g     :      Ty}
                    -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                    -> (that  :                      Local typeR typeL typeM rs g)
                             -> Type}
            -> (rec : Term.Project merge whom      x       y)
                   -> Term.Project merge whom (Rec x) (Rec y)

        ChoiceSelect : {merge : {rs    : List Ty}
                             -> {g     :      Ty}
                             -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                             -> (that  :                      Local typeR typeL typeM rs g)
                                      -> Type}
                    -> (prfS : whom = s)
                    -> (ss   : List1.Project merge whom bs cs)

                            -> Project merge whom (Choice        s r notsr bs)
                                                  (Choice SELECT   r       cs)

        ChoiceBranch : {merge : {rs    : List Ty}
                             -> {g     :      Ty}
                             -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                             -> (that  :                      Local typeR typeL typeM rs g)
                                      -> Type}
                    -> (prfR : whom = r)
                    -> (cs   : List1.Project merge whom bs bs')
                            -> Term.Project  merge whom (Choice        s r notsr bs)
                                                        (Choice BRANCH s         bs')

        ChoiceMerge : {merge : {rs    : List Ty}
                            -> {g     :      Ty}
                            -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                            -> (that  :                      Local typeR typeL typeM rs g)
                                     -> Type}
                   -> (prfWS : Not (whom = s))
                   -> (prfWR : Not (whom = r))

                   -> (ss    : List1.Project merge whom bs ((cl,cm,c):::cs))

                   -> (prf   : merge ((cl,cm,c):::cs) d)
                            -> Project merge whom (Choice s r notsr bs)
                                                  d

  namespace List

    public export
    data Project : (tyHowMerge : {rs    : List Ty}
                              -> {g     :      Ty}
                              -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                              -> (that  :                      Local typeR typeL typeM rs g)
                                       -> Type)
                -> (role : typeR)
                -> (bs   : List (typeL, typeM, Global typeR typeL typeM rs g))
                -> (bs'  : List (typeL, typeM, Local  typeR typeL typeM rs g))
                        -> Type
      where
        Empty : {merge : {rs    : List Ty}
                      -> {g     :      Ty}
                      -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                      -> (that  :                      Local typeR typeL typeM rs g)
                               -> Type}
                      -> Project merge whom Nil Nil

        Ext : {merge : {rs    : List Ty}
                    -> {g     :      Ty}
                    -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                    -> (that  :                      Local typeR typeL typeM rs g)
                             -> Type}
           -> (this : Term.Project merge whom         x               y)
           -> (rest : List.Project merge whom             xs              ys)
                   -> List.Project merge whom ((xl,xm,x)::xs) ((xl,xm,y)::ys)

  namespace List1

    public export
    data Project : (tyHowMerge : {rs : List Ty}
                              -> {g  :      Ty}
                              -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                              -> (that  :                      Local typeR typeL typeM rs g)
                                       -> Type)
                -> (role : typeR)
                -> (bs   : List1 (typeL, typeM, Global typeR typeL typeM rs g))
                -> (bs'  : List1 (typeL, typeM, Local  typeR typeL typeM rs g))
                        -> Type
      where
        Proj : {merge : {rs    : List Ty}
                    -> {g     :      Ty}
                    -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                    -> (that  :                      Local typeR typeL typeM rs g)
                             -> Type}
            -> (what  : List.Project  merge whom (b ::bs) (c ::cs))
                     -> List1.Project merge whom (b:::bs) (c:::cs)

mutual
  namespace Term

    public export
    project : DecEq typeR typeL typeM
           => {mergeTy : {rs    : List Ty}
                      -> {g     :      Ty}
                      -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                      -> (that  :                      Local typeR typeL typeM rs g)
                               -> Type}
           -> (mergeOp : {rs   : List Ty}
                      -> {g    :      Ty}
                      -> (this : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                              -> Maybe (that ** mergeTy this that))
           -> {rs    : List Ty}
           -> {g     :      Ty}
           -> (role  : typeR)
           -> (termG : Global typeR typeL typeM rs g)
                    -> Maybe (termL ** Project mergeTy role termG termL)

    project _ _ End
      = Just (End ** End)

    project _ _ (Call x)
      = Just (Call x ** Call)

    project mergeOp role (Rec x)
      = do (x' ** prf) <- project mergeOp role x
           pure (Rec x' ** Rec prf)

    project mergeOp role (Choice s r notSR cs) with (involved role s r notSR)
      project mergeOp role (Choice role r notSR cs) | (Sends Refl)
        = do (cs' ** prf) <- project mergeOp role cs
             pure (Choice SELECT r cs' ** ChoiceSelect Refl prf)

      project mergeOp role (Choice s role notSR cs) | (Recvs Refl)
        = do (cs' ** prf) <- project mergeOp role cs
             pure (Choice BRANCH s cs' ** ChoiceBranch Refl prf)

      project mergeOp role (Choice s r notSR cs) | (Skips prfSNot prfRNot)
        = do ((l,(m,c')) ::: tail ** prfProj) <- project mergeOp role cs
             (c ** prfMerge) <- mergeOp ((l,(m,c')) ::: tail)
             pure (c ** ChoiceMerge prfSNot prfRNot prfProj prfMerge)

  namespace List

    public export
    project : DecEq typeR typeL typeM
           => {mergeTy : {rs    : List Ty}
                      -> {g     :      Ty}
                      -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                      -> (that  :                      Local typeR typeL typeM rs g)
                               -> Type}
           -> (mergeOp : {rs   : List Ty}
                      -> {g    :      Ty}
                      -> (this : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                              -> Maybe (that ** mergeTy this that))

           -> {rs   : List Ty}
           -> {g    :      Ty}
           -> (role : typeR)
           -> (bs   : List (typeL, typeM, Global typeR typeL typeM rs g))
                   -> Maybe (bs' ** List.Project mergeTy role bs bs')

    project _ _ []
      = pure (Nil ** Empty)

    project mergeOp role ((l,(m,x)) :: xs)

      = do (x'  ** prfX)  <- Term.project mergeOp role x
           (xs' ** prfXs) <- List.project mergeOp role xs

           pure ((l,(m,x')) :: xs' ** Ext prfX prfXs)

  namespace List1

    public export
    project : DecEq typeR typeL typeM
           => {mergeTy : {rs    : List Ty}
                      -> {g     :      Ty}
                      -> (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                      -> (that  :                      Local typeR typeL typeM rs g)
                               -> Type}
           -> (mergeOp : {rs   : List Ty}
                      -> {g    :      Ty}
                      -> (this : List1 (typeL, typeM, Local typeR typeL typeM rs g))
                              -> Maybe (that ** mergeTy this that))

           -> {rs    : List Ty}
           -> {g     :      Ty}
           -> (role  : typeR)
           -> (termG : List1 (typeL, typeM, Global typeR typeL typeM rs g))
                    -> Maybe (termL ** Project mergeTy role termG termL)

    project mergeOp role (head ::: tail)
      = do (x::xs ** prf) <- List.project mergeOp role (head::tail)
           pure (x:::xs ** Proj prf)

-- [ EOF ]


module Data.DPair

%default total

namespace Exists

  ||| A dependent pair in which the first field (witness) should be
  ||| erased at runtime.
  |||
  ||| We can use `Exists` to construct dependent types in which the
  ||| type-level value is erased at runtime but used at compile time.
  ||| This type-level value could represent, for instance, a value
  ||| required for an intrinsic invariant required as part of the
  ||| dependent type's representation.
  |||
  ||| @type The type of the type-level value in the proof.
  ||| @this The dependent type that requires an instance of `type`.
  public export
  data Exists : (this : type -> Type) -> Type where
    Evidence : (0 value : type)
            -> (prf : this value)
            -> Exists this

  ||| Return the type-level value (evidence) required by the dependent type.
  |||
  ||| We need to be in the Erased setting for this to work.
  |||
  ||| @type The type-level value's type.
  ||| @pred The dependent type that requires an instance of `type`.
  ||| @prf  That there is a value that satisfies `prf`.
  public export
  0
  fst : {0 type : Type}
     -> {0 pred : type -> Type}
     -> (1 prf  : Exists pred)
     -> type
  fst (Evidence value _) = value

  ||| Return the dependently typed value.
  |||
  ||| @type The type-level value's type.
  ||| @pred The dependent type that requires an instance of `type`.
  ||| @prf  That there is a value that satisfies `prf`.
  public export
  snd : {0 type : Type}
     -> {0 pred : type -> Type}
     -> (1 prf  : Exists pred)
     -> pred (Exists.fst prf)
  snd (Evidence value prf) = prf

namespace Subset

  ||| A dependent pair in which the second field (evidence) should not
  ||| be required at runtime.
  |||
  ||| We can use `Subset` to provide extrinsic invariants about a
  ||| value and know that these invariants are erased at
  ||| runtime but used at compile time.
  |||
  ||| @type The type-level value's type.
  ||| @pred The dependent type that requires an instance of `type`.
  public export
  data Subset : (type : Type)
             -> (pred : type -> Type)
             -> Type
    where
      Element : (value : type)
             -> (0 prf : pred value)
             -> Subset type pred

  ||| Return the type-level value (evidence) required by the dependent type.
  |||
  ||| @type The type-level value's type.
  ||| @pred The dependent type that requires an instance of `type`.
  ||| @prf  That there is a value that satisfies `prf`.
  public export
  fst : {0 type : Type}
     -> {0 pred : type -> Type}
     -> (1 prf  : Subset type pred)
     -> type
  fst (Element value prf) = value

  ||| Return the dependently typed value.
  |||
  ||| We need to be in the erased setting for this to work.
  |||
  ||| @type The type-level value's type.
  ||| @pred The dependent type that requires an instance of `type`.
  ||| @prf  That there is a value that satisfies `prf`.
  public export
  0
  snd : {0 type : Type}
     -> {0 pred : type -> Type}
     -> (1 value : Subset type pred)
     -> pred (Subset.fst value)
  snd (Element value prf) = prf


||| Module that provides fixed-point number to represent seconds in nanoseconds.
module Fixed

public export
data Fixed a = MkFixed Integer

public export
data E12
data E9
data E2

public export
Dec : Type
Dec = Fixed E2

public export
Pico : Type
Pico = Fixed E12

public export
Nano : Type
Nano = Fixed E9

public export
Show (Fixed a) where
  show (MkFixed x) = show x

export
Eq (Fixed a) where
  (MkFixed a) == (MkFixed b) = a == b

export
Ord (Fixed a) where
  compare (MkFixed a) (MkFixed b) = compare a b

export
interface HasResolution (a: Type) where
  resolution : (f : Type -> Type) -> f a -> Integer

export
HasResolution E12 where
  resolution _ _ =  1000000000000

export
HasResolution E2 where
  resolution _ _ =  100

public export
Enum (Fixed a) where
  pred (MkFixed x) = MkFixed (pred x)
  toNat (MkFixed x) = toNat x
  fromNat x = MkFixed (toIntegerNat x)

-- Currently unable to express `*` in terms of `div` due to totality checking
-- implementation (HasResolution a) => Num (Fixed a) where
--   (+) (MkFixed x) (MkFixed y) = MkFixed (x + y)
--   (*) fa@(MkFixed x) (MkFixed y)  = MkFixed (div (x * y) (resolution {a} Fixed fa))
--   fromInteger x = MkFixed x

export
add: Fixed a -> Fixed a -> Fixed a
add (MkFixed x) (MkFixed y) = MkFixed (x + y)

export
(+) : Fixed a -> Fixed a -> Fixed a
(+) = add

export
sub : Fixed a -> Fixed a -> Fixed a
sub (MkFixed x) (MkFixed y) = MkFixed (x - y)

export
(-) : Fixed a -> Fixed a -> Fixed a
(-) = sub

export
negate: Fixed a -> Fixed a
negate (MkFixed x) = MkFixed (negate x)

export
abs : Fixed a -> Fixed a
abs (MkFixed x) = MkFixed (abs x)

export
fromInteger : Integer -> Fixed a
fromInteger x = MkFixed x

export
toRational : (HasResolution a) => Fixed a -> Double
toRational {a} fa@(MkFixed x) = (cast x) / cast (resolution {a} Fixed fa)

export
multFixed : (HasResolution a) => Fixed a -> Fixed a -> Fixed a
multFixed {a} fa@(MkFixed x) (MkFixed y) =
  let
    result =  div (x * y) (resolution {a} Fixed fa)
  in
    MkFixed result

--MkFixed (x * y  * cast (1 / (resolution {a} Fixed fa)))

export
(*) : (HasResolution a) => Fixed a -> Fixed a -> Fixed a
(*) = multFixed

export
fracDiv : (HasResolution a) => Fixed a -> Fixed a -> Fixed a
fracDiv fa@(MkFixed x) (MkFixed y) = MkFixed (div (x * (resolution {a} Fixed fa)) y)

export
(/): (HasResolution a) => Fixed a -> Fixed a -> Fixed a
(/) = fracDiv

export
recip : (HasResolution a) => Fixed a -> Fixed a
recip {a} fa@(MkFixed x) = MkFixed (div ((resolution {a} Fixed fa) * (resolution {a} Fixed fa)) x)

-- TODO:
-- fromRationalFixed:

-- implementation (HasResolution a) => Num (Fixed a) where
--   (+) (MkFixed x) (MkFixed y) = addFixed
--   (*) fa@(MkFixed x) (MkFixed y)  = MkFixed (x * y * (resolution {a} Fixed fa))
--   fromInteger x = MkFixed x

--(HasResolution a) => Fractional (Fixed a) where
--  (/) = fraceDivFixed
--   --recip fa@(MkFixed x) =

--   -- MkFixed (div (res * res) x)
--   --                        where
--   --                        res = (resolution {a} Fixed fa)

-- partial
-- implementation (HasResolution a) => Integral (Fixed a) where
--   div (MkFixed x) (MkFixed y) = MkFixed (div x y)
--   mod (MkFixed x) (MkFixed y) = MkFixed (mod x y)

  --fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))

  -- (MkFixed a) + (MkFixed b) = MkFixed (a + b)
  -- (MkFixed a) - (MkFixed b) = MkFixed (a - b)
  -- fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (resolution fa))
  -- negate (MkFixed a) = MkFixed (negate a)
  -- abs (MkFixed a) = MkFixed (abs a)
  -- signum (MkFixed a) = fromInteger (signum a)
  -- fromInteger i = withResolution (\res -> MkFixed (i * res))


module IxFreer

Eff : Type -> Type
Eff r = r -> (a : Type) -> (a -> r) -> Type

data IxFreer : {r : Type} -> (f : Eff r) -> Eff r where
  Pure : (x : a) -> IxFreer f (s' x) a s'
  Bind : {f : Eff r} -> f s a s' -> ((x : a) -> IxFreer f (s' x) b s'') -> IxFreer f s b s''

(>>=) : IxFreer f s a s' -> ((x : a) -> IxFreer f (s' x) b s'') -> IxFreer f s b s''
(>>=) (Pure x) f = f x
(>>=) (Bind x f) g = Bind x (\y => f y >>= g)

-- Example from https://www.idris-lang.org/drafts/sms.pdf
data Access = LoggedOut | LoggedIn
data LoginResult = OK | BadPassword

data Store : Access -> (ty : Type) -> (ty -> Access) -> Type where
  Login : Store LoggedOut LoginResult (\res => case res of
                                                  OK => LoggedIn
                                                  BadPassword => LoggedOut)

  Logout : Store LoggedIn () (const LoggedOut)
  ReadSecret : Store LoggedIn String (const LoggedIn)
  Lift : IO ty -> Store st ty (const st)

login : IxFreer Store LoggedOut LoginResult (\res => case res of
                                                      OK => LoggedIn
                                                      BadPassword => LoggedOut)
login = Bind Login Pure

logout : IxFreer Store LoggedIn () (const LoggedOut)
logout = Bind Logout Pure

readSecret : IxFreer Store LoggedIn String (const LoggedIn)
readSecret = Bind ReadSecret Pure

lift : IO ty -> IxFreer Store st ty (const st)
lift io = Bind (Lift io) Pure

getData : IxFreer Store LoggedOut () (const LoggedOut)
getData = do result <- login
             case result of
               OK => do secret <- readSecret
                        lift (putStr ("Secret: " ++ show secret ++ "\n"))
                        logout
               BadPassword => lift (putStr "Failure\n")

run : IxFreer Store s () s' -> IO ()
run (Pure x) = pure x
run (Bind Login g) = run (g OK)
run (Bind Logout g) = run (g ())
run (Bind ReadSecret g) = run (g "secret")
run (Bind (Lift io) g) = io >>= \x => run (g x)

test : IO ()
test = run getData


-- Implementation based on https://www.newspipe.org/article/public/309714

module Crypto.Hash.Poly1305

import Data.Vect
import Utils.Misc
import Utils.Bytes
import Data.Bits
import Crypto.Hash

export
record Poly1305 where
  constructor MkPoly1305
  buffer : List Bits8
  h : Vect 3 Bits64
  r : Vect 2 Bits64
  s : Vect 2 Bits64

record Bits128 where
  constructor MkBits128
  lo : Bits64
  hi : Bits64

mask_low_2_bits : Bits64
mask_low_2_bits  = 0x0000000000000003

mask_not_low_2_bits : Bits64
mask_not_low_2_bits = complement mask_low_2_bits

p0 : Bits64
p0 = 0xFFFFFFFFFFFFFFFB

p1 : Bits64
p1 = 0xFFFFFFFFFFFFFFFF

p2 : Bits64
p2 = 0x0000000000000003

add64 : Bits64 -> Bits64 -> Bits64 -> (Bits64, Bits64)
add64 x y carry =
  let sum = x + y + carry
      carry = shiftR ((x .&. y) .|. ((x .|. y) .&. (complement sum))) 63
  in (sum, carry)

sub64 : Bits64 -> Bits64 -> Bits64 -> (Bits64, Bits64)
sub64 x y borrow =
  let diff = x - y - borrow
      borrow_out = shiftR ((complement x .&. y) .|. (diff .&. complement (x `xor` y))) 63
  in (diff, borrow_out)

mul64_mask32 : Bits64
mul64_mask32 = cast (the Bits32 oneBits)

mul64 : Bits64 -> Bits64 -> Bits128
mul64 x y =
  let x0 = x .&. mul64_mask32
      x1 = shiftR x 32
      y0 = y .&. mul64_mask32
      y1 = shiftR y 32
      w0 = x0 * y0
      t = (x1 * y0) + (shiftR w0 32)
      w1 = t .&. mul64_mask32
      w2 = shiftR t 32
      w1 = w1 + (x0 * y1)
  in MkBits128 (x * y) (x1 * y1 + w2 + (shiftR w1 32))

add128 : Bits128 -> Bits128 -> Bits128
add128 a b =
  let (lo, c) = add64 a.lo b.lo 0
      (hi, _) = add64 a.hi b.hi c
  in MkBits128 lo hi

shiftr2 : Bits128 -> Bits128
shiftr2 a = MkBits128 ((shiftR a.lo 2) .|. (shiftL (a.hi .&. 3) 62)) (shiftR a.hi 2)

-- select64 returns x if v == 1 and y if v == 0, in constant time
select64 : Bits64 -> Bits64 -> Bits64 -> Bits64
select64 v x y = (x .&. complement (v - 1)) .|. (y .&. (v - 1))

core : Poly1305 -> Bits64 -> Bits64 -> Bits64 -> (Bits64, Bits64, Bits64)
core state h0 h1 h2 =
  let [r0, r1] = state.r

      h0r0 = mul64 h0 r0
      h1r0 = mul64 h1 r0
      h2r0 = mul64 h2 r0
      h0r1 = mul64 h0 r1
      h1r1 = mul64 h1 r1
      h2r1 = mul64 h2 r1

      m0 = h0r0
      m1 = add128 h1r0 h0r1
      m2 = add128 h2r0 h1r1
      m3 = h2r1

      t0 = m0.lo
      (t1, c) = add64 m1.lo m0.hi 0
      (t2, c) = add64 m2.lo m1.hi c
      (t3, _) = add64 m3.lo m2.hi c

      h0 = t0
      h1 = t1
      h2 = t2 .&. mask_low_2_bits
      cc = MkBits128 (t2 .&. mask_not_low_2_bits) t3

      (h0, c) = add64 h0 cc.lo 0
      (h1, c) = add64 h1 cc.hi c
      h2 = h2 + c

      cc = shiftr2 cc

      (h0, c) = add64 h0 cc.lo 0
      (h1, c) = add64 h1 cc.hi c
      h2 = h2 + c
  in (h0, h1, h2)

update' : Poly1305 -> Poly1305
update' state =
  case splitAtExact 16 state.buffer of
    Just (buf, rest) =>
      let (a, b) = bimap from_le from_le (splitAt 8 buf)
          [h0, h1, h2] = state.h
          (h0, c) = add64 h0 a 0
          (h1, c) = add64 h1 b c
          h2 = h2 + c + 1
          (h0, h1, h2) = core state h0 h1 h2
      in {h := [h0, h1, h2]} state
    Nothing => state

finalize' : Poly1305 -> Vect 16 Bits8
finalize' state =
  case exactLength 16 (fromList state.buffer) of
    Just buf =>
      let (a, b) = bimap from_le from_le (splitAt 8 buf)
          [h0, h1, h2] = state.h
          (h0, c) = add64 h0 a 0
          (h1, c) = add64 h1 b c
          h2 = h2 + c
          (h0, h1, h2) = core state h0 h1 h2

          (t0, b) = sub64 h0 p0 0
          (t1, b) = sub64 h1 p1 b
          (_ , b) = sub64 h2 p2 b

          h0 = select64 b h0 t0
          h1 = select64 b h1 t1

          [s0, s1] = state.s
          (h0, c) = add64 h0 s0 0
          (h1, _) = add64 h1 s1 c
      in to_le {n=8} h0 ++ to_le {n=8} h1
    Nothing =>
      finalize' $ { buffer := pad_zero 16 (state.buffer <+> [ 0x01 ]) } (update' state)

export
Digest Poly1305 where
  digest_nbyte = 16
  update message state = update' $ {buffer := state.buffer <+> message} state
  finalize = finalize'

export
MAC (Vect 32 Bits8) Poly1305 where
  initialize_mac key =
    let ([r0, r1], s) = splitAt 2 $ map from_le $ group 4 8 key
        r0 = r0 .&. 0x0FFFFFFC0FFFFFFF
        r1 = r1 .&. 0x0FFFFFFC0FFFFFFC
    in MkPoly1305 [] [0,0,0] [r0, r1] s


module Data.Bits

import Data.DPair
import public Data.Nat

%default total

infixl 8 `shiftL`, `shiftR`
infixl 7 .&.
infixl 6 `xor`
infixl 5 .|.

||| Utility for using bitwise operations at compile
||| time.
|||
||| ```idris example
||| the Bits8 13 `shiftL` fromNat 3
||| ```
export
fromNat :  (k : Nat)
        -> {n : Nat}
        -> {auto 0 prf : lt k n === True}
        -> Subset Nat (`LT` n)
fromNat k = Element k (ltReflectsLT k n prf)

--------------------------------------------------------------------------------
--          Interface Bits
--------------------------------------------------------------------------------

||| The `Bits` interface defines bitwise operations over integral types.
public export
interface Bits a where
  0 Index : Type

  ||| Bitwise "and"
  (.&.) : a -> a -> a

  ||| Bitwise "or"
  (.|.) : a -> a -> a

  ||| Bitwise "xor".
  xor : a -> a -> a

  ||| Shift the argument left by the specified number of bits.
  shiftL : a -> Index -> a

  ||| Shift the argument right by the specified number of bits.
  shiftR : a -> Index -> a

  ||| Sets the `i`-th bit.
  bit : (i : Index) -> a

  ||| The value with all bits unset.
  zeroBits : a

  ||| Returns the bitwise complement of a value.
  complement : a -> a

  ||| The value with all bits set..
  oneBits : a
  oneBits = complement zeroBits

  ||| `complementBit x i` is the same as `xor x (bit i)`.
  complementBit : (x : a) -> (i : Index) -> a
  complementBit x i = x `xor` bit i

  ||| `clearBit x i` is the same as `x .&. complement (bit i)`
  clearBit : (x : a) -> (i : Index) -> a
  clearBit x i = x `xor` (bit i .&. x)

  ||| Tests, whether the i-th bit is set in the given value.
  testBit : a -> Index -> Bool

  ||| Sets the i-th bit of a value.
  setBit : a -> (i : Index) -> a
  setBit x i = x .|. bit i

public export %inline
Bits Bits8 where
  Index       = Subset Nat (`LT` 8)
  (.&.)       = prim__and_Bits8
  (.|.)       = prim__or_Bits8
  xor         = prim__xor_Bits8
  bit         = (1 `shiftL`)
  zeroBits    = 0
  testBit x i = (x .&. bit i) /= 0
  shiftR x    = prim__shr_Bits8 x . cast . fst
  shiftL x    = prim__shl_Bits8 x . cast . fst
  complement  = xor 0xff
  oneBits     = 0xff

public export %inline
Bits Bits16 where
  Index       = Subset Nat (`LT` 16)
  (.&.)       = prim__and_Bits16
  (.|.)       = prim__or_Bits16
  xor         = prim__xor_Bits16
  bit         = (1 `shiftL`)
  zeroBits    = 0
  testBit x i = (x .&. bit i) /= 0
  shiftR x    = prim__shr_Bits16 x . cast . fst
  shiftL x    = prim__shl_Bits16 x . cast . fst
  complement  = xor 0xffff
  oneBits     = 0xffff

public export %inline
Bits Bits32 where
  Index       = Subset Nat (`LT` 32)
  (.&.)       = prim__and_Bits32
  (.|.)       = prim__or_Bits32
  xor         = prim__xor_Bits32
  bit         = (1 `shiftL`)
  zeroBits    = 0
  testBit x i = (x .&. bit i) /= 0
  shiftR x    = prim__shr_Bits32 x . cast . fst
  shiftL x    = prim__shl_Bits32 x . cast . fst
  complement  = xor 0xffffffff
  oneBits     = 0xffffffff

public export %inline
Bits Bits64 where
  Index       = Subset Nat (`LT` 64)
  (.&.)       = prim__and_Bits64
  (.|.)       = prim__or_Bits64
  xor         = prim__xor_Bits64
  bit         = (1 `shiftL`)
  zeroBits    = 0
  testBit x i = (x .&. bit i) /= 0
  shiftR x    = prim__shr_Bits64 x . cast . fst
  shiftL x    = prim__shl_Bits64 x . cast . fst
  complement  = xor 0xffffffffffffffff
  oneBits     = 0xffffffffffffffff

public export %inline
Bits Int where
  Index       = Subset Nat (`LT` 64)
  (.&.)       = prim__and_Int
  (.|.)       = prim__or_Int
  xor         = prim__xor_Int
  bit         = (1 `shiftL`)
  zeroBits    = 0
  testBit x i = (x .&. bit i) /= 0
  shiftR x    = prim__shr_Int x . cast . fst
  shiftL x    = prim__shl_Int x . cast . fst
  complement  = xor (-1)
  oneBits     = (-1)

public export %inline
Bits Int8 where
  Index       = Subset Nat (`LT` 8)
  (.&.)       = prim__and_Int8
  (.|.)       = prim__or_Int8
  xor         = prim__xor_Int8
  bit         = (1 `shiftL`)
  zeroBits    = 0
  testBit x i = (x .&. bit i) /= 0
  shiftR x    = prim__shr_Int8 x . cast . fst
  shiftL x    = prim__shl_Int8 x . cast . fst
  complement  = xor (-1)
  oneBits     = (-1)

public export %inline
Bits Int16 where
  Index       = Subset Nat (`LT` 16)
  (.&.)       = prim__and_Int16
  (.|.)       = prim__or_Int16
  xor         = prim__xor_Int16
  bit         = (1 `shiftL`)
  zeroBits    = 0
  testBit x i = (x .&. bit i) /= 0
  shiftR x    = prim__shr_Int16 x . cast . fst
  shiftL x    = prim__shl_Int16 x . cast . fst
  complement  = xor (-1)
  oneBits     = (-1)

public export %inline
Bits Int32 where
  Index       = Subset Nat (`LT` 32)
  (.&.)       = prim__and_Int32
  (.|.)       = prim__or_Int32
  xor         = prim__xor_Int32
  bit         = (1 `shiftL`)
  zeroBits    = 0
  testBit x i = (x .&. bit i) /= 0
  shiftR x    = prim__shr_Int32 x . cast . fst
  shiftL x    = prim__shl_Int32 x . cast . fst
  complement  = xor (-1)
  oneBits     = (-1)

public export %inline
Bits Int64 where
  Index       = Subset Nat (`LT` 64)
  (.&.)       = prim__and_Int64
  (.|.)       = prim__or_Int64
  xor         = prim__xor_Int64
  bit         = (1 `shiftL`)
  zeroBits    = 0
  testBit x i = (x .&. bit i) /= 0
  shiftR x    = prim__shr_Int64 x . cast . fst
  shiftL x    = prim__shl_Int64 x . cast . fst
  complement  = xor (-1)
  oneBits     = (-1)

public export %inline
Bits Integer where
  Index       = Nat
  (.&.)       = prim__and_Integer
  (.|.)       = prim__or_Integer
  xor         = prim__xor_Integer
  bit         = (1 `shiftL`)
  zeroBits    = 0
  testBit x i = (x .&. bit i) /= 0
  shiftR x    = prim__shr_Integer x . natToInteger
  shiftL x    = prim__shl_Integer x . natToInteger
  complement  = xor (-1)
  oneBits     = (-1)

--------------------------------------------------------------------------------
--          FiniteBits
--------------------------------------------------------------------------------

public export
interface Bits a => FiniteBits a where
  ||| Return the number of bits in values of type `t`.
  bitSize : Nat

  ||| Properly correlates `bitSize` and `Index`.
  bitsToIndex : Subset Nat (`LT` bitSize) -> Index {a}

  ||| Return the number of set bits in the argument.  This number is
  ||| known as the population count or the Hamming weight.
  popCount : a -> Nat

public export %inline
FiniteBits Bits8 where
  bitSize     = 8
  bitsToIndex = id

  popCount x0 =
    -- see https://stackoverflow.com/questions/109023/how-to-count-the-number-of-set-bits-in-a-32-bit-integer
    let x1 = (x0 .&. 0x55) + ((x0 `shiftR` fromNat 1) .&. 0x55)
        x2 = (x1 .&. 0x33) + ((x1 `shiftR` fromNat 2) .&. 0x33)
        x3 = ((x2 + (x2 `shiftR` fromNat 4)) .&. 0x0F)
     in cast x3

public export %inline
FiniteBits Bits16 where
  bitSize     = 16
  bitsToIndex = id

  popCount x0 =
    -- see https://stackoverflow.com/questions/109023/how-to-count-the-number-of-set-bits-in-a-32-bit-integer
    let x1 = (x0 .&. 0x5555) + ((x0 `shiftR` fromNat 1) .&. 0x5555)
        x2 = (x1 .&. 0x3333) + ((x1 `shiftR` fromNat 2) .&. 0x3333)
        x3 = ((x2 + (x2 `shiftR` fromNat 4)) .&. 0x0F0F)
        x4 = (x3 * 0x0101) `shiftR` fromNat 8
     in cast x4

public export %inline
FiniteBits Bits32 where
  bitSize     = 32
  bitsToIndex = id

  popCount x0 =
    -- see https://stackoverflow.com/questions/109023/how-to-count-the-number-of-set-bits-in-a-32-bit-integer
    let x1 = (x0 .&. 0x55555555) + ((x0 `shiftR` fromNat 1) .&. 0x55555555)
        x2 = (x1 .&. 0x33333333) + ((x1 `shiftR` fromNat 2) .&. 0x33333333)
        x3 = ((x2 + (x2 `shiftR` fromNat 4)) .&. 0x0F0F0F0F)
        x4 = (x3 * 0x01010101) `shiftR` fromNat 24
     in cast x4

public export %inline
FiniteBits Bits64 where
  bitSize     = 64
  bitsToIndex = id

  popCount x0 =
    -- see https://stackoverflow.com/questions/109023/how-to-count-the-number-of-set-bits-in-a-64-bit-integer
    let x1 = (x0 .&. 0x5555555555555555) +
             ((x0 `shiftR` fromNat 1) .&. 0x5555555555555555)
        x2 = (x1 .&. 0x3333333333333333)
             + ((x1 `shiftR` fromNat 2) .&. 0x3333333333333333)
        x3 = ((x2 + (x2 `shiftR` fromNat 4)) .&. 0x0F0F0F0F)
        x4 = (x3 * 0x0101010101010101) `shiftR` fromNat 56
     in cast x4

public export %inline
FiniteBits Int where
  bitSize     = 64
  bitsToIndex = id

  popCount x =
    -- see https://stackoverflow.com/questions/109023/how-to-count-the-number-of-set-bits-in-a-32-bit-integer
    -- We have to treat negative numbers separately in order to
    -- prevent overflows in the first addition.
    -- The top bit is therefore cleared and 1 is added in the end
    -- in case of a negative number
    let x0 = x `clearBit` fromNat 63
        x1 = (x0 .&. 0x5555555555555555)
           + ((x0 `shiftR` fromNat 1) .&. 0x5555555555555555)
        x2 = (x1 .&. 0x3333333333333333)
           + ((x1 `shiftR` fromNat 2) .&. 0x3333333333333333)
        x3 = ((x2 + (x2 `shiftR` fromNat 4)) .&. 0x0F0F0F0F0F0F0F0F)
        x4 = (x3 * 0x0101010101010101) `shiftR` fromNat 56
        x5 = if x < 0 then x4 + 1 else x4
     in cast x5

public export %inline
FiniteBits Int8 where
  bitSize     = 8
  bitsToIndex = id

  popCount x =
    -- see https://stackoverflow.com/questions/109023/how-to-count-the-number-of-set-bits-in-a-32-bit-integer
    -- We have to treat negative numbers separately in order to
    -- prevent overflows in the first addition.
    -- The top bit is therefore cleared and 1 is added in the end
    -- in case of a negative number
    let x0 = x `clearBit` fromNat 7
        x1 = (x0 .&. 0x55) + ((x0 `shiftR` fromNat 1) .&. 0x55)
        x2 = (x1 .&. 0x33) + ((x1 `shiftR` fromNat 2) .&. 0x33)
        x3 = ((x2 + (x2 `shiftR` fromNat 4)) .&. 0x0F)
        x4 = if x < 0 then x3 + 1 else x3
     in cast x4

public export %inline
FiniteBits Int16 where
  bitSize     = 16
  bitsToIndex = id

  popCount x =
    -- see https://stackoverflow.com/questions/109023/how-to-count-the-number-of-set-bits-in-a-32-bit-integer
    -- We have to treat negative numbers separately in order to
    -- prevent overflows in the first addition.
    -- The top bit is therefore cleared and 1 is added in the end
    -- in case of a negative number
    let x0 = x `clearBit` fromNat 15
        x1 = (x0 .&. 0x5555) + ((x0 `shiftR` fromNat 1) .&. 0x5555)
        x2 = (x1 .&. 0x3333) + ((x1 `shiftR` fromNat 2) .&. 0x3333)
        x3 = ((x2 + (x2 `shiftR` fromNat 4)) .&. 0x0F0F)
        x4 = (x3 * 0x0101) `shiftR` fromNat 8
        x5 = if x < 0 then x4 + 1 else x4
     in cast x5

public export %inline
FiniteBits Int32 where
  bitSize     = 32
  bitsToIndex = id

  popCount x =
    -- see https://stackoverflow.com/questions/109023/how-to-count-the-number-of-set-bits-in-a-32-bit-integer
    -- We have to treat negative numbers separately in order to
    -- prevent overflows in the first addition.
    -- The top bit is therefore cleared and 1 is added in the end
    -- in case of a negative number
    let x0 = x `clearBit` fromNat 31
        x1 = (x0 .&. 0x55555555) + ((x0 `shiftR` fromNat 1) .&. 0x55555555)
        x2 = (x1 .&. 0x33333333) + ((x1 `shiftR` fromNat 2) .&. 0x33333333)
        x3 = ((x2 + (x2 `shiftR` fromNat 4)) .&. 0x0F0F0F0F)
        x4 = (x3 * 0x01010101) `shiftR` fromNat 24
        x5 = if x < 0 then x4 + 1 else x4
     in cast x5

public export %inline
FiniteBits Int64 where
  bitSize     = 64
  bitsToIndex = id

  popCount x =
    -- see https://stackoverflow.com/questions/109023/how-to-count-the-number-of-set-bits-in-a-32-bit-integer
    -- We have to treat negative numbers separately in order to
    -- prevent overflows in the first addition.
    -- The top bit is therefore cleared and 1 is added in the end
    -- in case of a negative number
    let x0 = x `clearBit` fromNat 63
        x1 = (x0 .&. 0x5555555555555555)
           + ((x0 `shiftR` fromNat 1) .&. 0x5555555555555555)
        x2 = (x1 .&. 0x3333333333333333)
           + ((x1 `shiftR` fromNat 2) .&. 0x3333333333333333)
        x3 = ((x2 + (x2 `shiftR` fromNat 4)) .&. 0x0F0F0F0F0F0F0F0F)
        x4 = (x3 * 0x0101010101010101) `shiftR` fromNat 56
        x5 = if x < 0 then x4 + 1 else x4
     in cast x5


module SmallStepImp

import Expr
import Imp
import Maps
import SmallStepExpr

%access public export

%default total

data CStep : (Com, State) -> (Com, State) -> Type where
  CS_AssStep : AStep st a a' -> CStep (i ::= a, st) (i ::= a', st)
  CS_Ass : CStep (i ::= ANum n, st) (SKIP, t_update i n st)
  CS_SeqStep : CStep (c1, st) (c1', st') ->
               CStep ((do c1; c2), st) ((do c1'; c2), st')
  CS_SeqFinish : CStep ((do SKIP; c2), st) (c2, st)
  CS_IfStep : BStep st b b' -> CStep (CIf b c1 c2, st) (CIf b' c1 c2, st)
  CS_IfTrue : CStep (CIf BTrue c1 c2, st) (c1, st)
  CS_IfFalse : CStep (CIf BFalse c1 c2, st) (c2, st)
  CS_While : CStep (WHILE b c, st) (CIf b (do c; WHILE b c) SKIP, st)

syntax [t] "/" [st] "-+>" [t'] "/" [st'] = CStep (t, st) (t', st')


module Sub10Apply108x18

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total
-- %language ElabReflection

-- 3(36x+6) --F[5,-2]->E[2,-4]--> 3(8x+1)
fe108x18To24x3 :
  (o:Nat) ->  P (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))
                                  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))))
                            (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o))))))))) 2
    -> P (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))) 2
fe108x18To24x3 o prf =
  let prf2 = lvDown (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))
                                  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))))
                            (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o))))))))) 2
                    prf in
    let prf3 = fe108x18To24x3' o prf2 in lvDown (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))) 3 prf3

export
apply108x18 : P (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))
                                  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))))
                            (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o))))))))) 2
    -> (m : Nat **
        (LTE (S m)
             (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))
                                     (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))))
                               (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o))))))))),
         P m 2))
apply108x18 {o} col = let col2 = fe108x18To24x3 o col in ((S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                                           ** (lte108x18 o, col2)) where
  lte108x18 : (o:Nat) -> LTE (S (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))
          (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))
                                  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))))
                            (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (plus (plus (plus o o) o) (plus (plus o o) o)))))))))
  lte108x18 Z = (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc) LTEZero
  lte108x18 (S o) = let lemma = lte108x18 o in
    rewrite (sym (plusSuccRightSucc o o)) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (S (plus o o)))) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (plus o o))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (S (plus (plus o o) (plus o o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (plus (plus o o) (plus o o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (plus (plus o o) (plus o o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (plus (plus o o) (plus o o)))) in

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

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

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

    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o)
                                                                                (plus (plus o o)
                                                      o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))))
                                    (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o)
                                                                                (plus (plus o o)
                                                      o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))))
                                    (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o)
                                                                                (plus (plus o o)
                                                      o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))))
                                    (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o)
                                                                                (plus (plus o o)
                                                      o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))))
                                    (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o)
                                                                                (plus (plus o o)
                                                      o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))))
                                    (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o)
                                                                                (plus (plus o o)
                                                      o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))))
                                    (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o)
                                                                                (plus (plus o o)
                                                      o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))))
                                    (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o)
                                                                                (plus (plus o o)
                                                      o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))))
                                    (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o)
                                                                                (plus (plus o o)
                                                      o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))))
                                    (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o)
                                                                                (plus (plus o o)
                                                      o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))))
                                    (S (S (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o)
                                                                                (plus (plus o o)
                                                      o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o) (plus (plus o o) o)))))
                                    (S (plus (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))
                                                                                (plus (plus (plus o o) o)
                                                                                (plus (plus o o)
                                                      o)))))) in
      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) lemma


||| Module partially based on McBride's paper:
||| Turing-Completeness Totally Free
|||
||| It gives us a type to describe computation using general recursion
||| and functions to run these computations for a while or to completion
||| if we are able to prove them total.
|||
||| The content of the Erased section is new. Instead of producing the
||| domain/evaluation pair by computing a Dybjer-Setzer code we build a
||| specialised structure that allows us to make the domain proof runtime
||| irrelevant.

module Data.Recursion.Free

import Data.Late
import Data.InductionRecursion.DybjerSetzer

%default total

------------------------------------------------------------------------
-- Type

||| Syntax for a program using general recursion
public export
data General : (a : Type) -> (b : a -> Type) -> (x : Type) -> Type where
  ||| We can return a value without performing any recursive call.
  Tell : x -> General a b x
  ||| Or we can pick an input and ask an oracle to give us a return value
  ||| for it. The second argument is a continuation explaining what we want
  ||| to do with the returned value.
  Ask  : (i : a) -> (b i -> General a b x) -> General a b x

||| Type of functions using general recursion
public export
PiG : (a : Type) -> (b : a -> Type) -> Type
PiG a b = (i : a) -> General a b (b i)

||| Recursor for General
public export
fold : (x -> y) -> ((i : a) -> (b i -> y) -> y) -> General a b x -> y
fold pure ask (Tell x) = pure x
fold pure ask (Ask i k) = ask i (\ o => fold pure ask (k o))

------------------------------------------------------------------------
-- Basic functions

||| Perform a recursive call and return the value provided by the oracle.
public export
call : PiG a b
call i = Ask i Tell

||| Monadic bind (defined outside of the interface to be able to use it for
||| map and (<*>)).
public export
bind : General a b x -> (x -> General a b y) -> General a b y
bind m f = fold f Ask m

||| Given a monadic oracle we can give a monad morphism interpreting a
||| function using general recursion as a monadic process.
public export
monadMorphism : Monad m => (t : (i : a) -> m (b i)) -> General a b x -> m x
monadMorphism t = fold pure (\ i => (t i >>=))

------------------------------------------------------------------------
-- Instances

public export
Functor (General a b) where
  map f = fold (Tell . f) Ask

public export
Applicative (General a b) where
  pure = Tell
  gf <*> gv = bind gf (\ f => map (f $) gv)

public export
Monad (General a b) where
  (>>=) = bind

------------------------------------------------------------------------
-- Fuel-based (partial) evaluation

||| Check whehther we are ready to return a value
public export
already : General a b x -> Maybe x
already = monadMorphism (\ i => Nothing)

||| Use a function using general recursion to expand all of the oracle calls.
public export
expand : PiG a b -> General a b x -> General a b x
expand f = monadMorphism f

||| Recursively call expand a set number of times.
public export
engine : PiG a b -> Nat -> General a b x -> General a b x
engine f Z     = id
engine f (S n) = engine f n . expand f

||| Check whether recursively calling expand a set number of times is enough
||| to produce a value.
public export
petrol : PiG a b -> Nat -> (i : a) -> Maybe (b i)
petrol f n i = already $ engine f n $ f i

------------------------------------------------------------------------
-- Late-based evaluation

||| Rely on an oracle using general recursion to convert a function using
||| general recursion into a process returning a value in the (distant) future.
public export
late : PiG a b -> General a b x -> Late x
late f = monadMorphism (\ i => Later (assert_total $ late f (f i)))

||| Interpret a function using general recursion as a process returning
||| a value in the (distant) future.
public export
lazy : PiG a b -> (i : a) -> Late (b i)
lazy f i = late f (f i)

------------------------------------------------------------------------
-- Domain as a Dybjer-Setzer code and total evaluation function

namespace DybjerSetzer

  ||| Compute, as a Dybjer-Setzer code for an inductive-recursive type, the domain
  ||| of a function defined by general recursion.
  public export
  Domain : PiG a b -> (i : a) -> Code b (b i)
  Domain f i = monadMorphism ask (f i) where

    ask : (i : a) -> Code b (b i)
    ask i = Branch () (const i) $ \ t => Yield (t ())

  ||| If a given input is in the domain of the function then we may evaluate
  ||| it fully on that input and obtain a pure return value.
  public export
  evaluate : (f : PiG a b) -> (i : a) -> Mu (Domain f) i -> b i
  evaluate f i inDom = Decode inDom

  ||| If every input value is in the domain then the function is total.
  public export
  totally : (f : PiG a b) -> ((i : a) -> Mu (Domain f) i) ->
            (i : a) -> b i
  totally f allInDomain i = evaluate f i (allInDomain i)

------------------------------------------------------------------------
-- Runtime irrelevant domain and total evaluation function

namespace Erased

  ------------------------------------------------------------------------
  -- Domain and evaluation functions

  ||| What it means to describe a terminating computation
  ||| @ f is the function used to answer questions put to the oracle
  ||| @ d is the description of the computation
  public export
  data Layer : (f : PiG a b) -> (d : General a b (b i)) -> Type

  ||| The domain of a function (i.e. the set of inputs for which it terminates)
  ||| as a predicate on inputs
  ||| @ f is the function whose domain is being described
  ||| @ i is the input that is purported to be in the domain
  Domain : (f : PiG a b) -> (i : a) -> Type

  ||| Fully evaluate a computation known to be terminating.
  ||| Because of the careful design of the inductive family Layer, we can make
  ||| the proof runtime irrelevant.
  evaluateLayer : (f : PiG a b) -> (d : General a b (b i)) -> (0 _ : Layer f d) -> b i

  ||| Fully evaluate a function call for an input known to be in its domain.
  evaluate : (f : PiG a b) -> (i : a) -> (0 _ : Domain f i) -> b i

  -- In a classic Dybjer-Setzer situation this is computed by induction over the
  -- index of type `General a b (b i)` and the fixpoint called `Domain` is the
  -- one thing defined as an inductive type.
  -- Here we have to flip the script because Idris will only trust inductive data
  -- as a legitimate source of termination metric for a recursive function. This
  -- makes our definition of `evaluateLayer` obviously terminating.
  data Layer : PiG a b -> General a b (b i) -> Type where
    ||| A computation returning a value is trivially terminating
    MkTell : {0 a : Type} -> {0 b : a -> Type} -> {0 f : PiG a b} -> {0 i : a} ->
             (o : b i) -> Layer f (Tell o)

    ||| Performing a call to the oracle is termnating if the input is in its
    ||| domain and if the rest of the computation is also finite.
    MkAsk  : {0 a : Type} -> {0 b : a -> Type} -> {0 f : PiG a b} -> {0 i : a} ->
             (j : a) -> (jprf : Domain f j) ->
             (k : b j -> General a b (b i)) -> Layer f (k (evaluate f j jprf)) ->
             Layer f (Ask j k)

  -- Domain is simply defined as the top layer leading to a terminating
  -- computation with the function used as its own oracle.
  Domain f i = Layer f (f i)

  ||| A view that gives us a pattern-matching friendly presentation of the
  ||| @ d computation known to be terminating
  ||| @ l proof that it is
  ||| This may seem like a useless definition but the function `view`
  ||| demonstrates a very important use case: even if the proof is runtime
  ||| irrelevant, we can manufacture a satisfying view of it.
  data View : {d : General a b (b i)} -> (l : Layer f d) -> Type where
    TView : {0 b : a -> Type} -> {0 f : PiG a b} -> (o : b i) -> View (MkTell {b} {f} o)
    AView : {0 f : PiG a b} ->
            (j : a) -> (0 jprf : Domain f j) ->
            (k : b j -> General a b (b i)) -> (0 kprf : Layer f (k (evaluate f j jprf))) ->
            View (MkAsk j jprf k kprf)

  ||| Function computing the view by pattern-matching on the computation and
  ||| inverting the proof. Note that the proof is runtime irrelevant even though
  ||| the resulting view is not: this is possible because the relevant constructor
  ||| is uniquely determined by the shape of `d`.
  public export
  view : (d : General a b (b i)) -> (0 l : Layer f d) -> View l
  view (Tell o)  (MkTell o)            = TView o
  view (Ask j k) (MkAsk j jprf k kprf) = AView j jprf k kprf

  -- Just like `Domain` is defined in terms of `Layer`, the evaluation of a
  -- function call for an input in its domain can be reduced to the evaluation
  -- of a layer.
  evaluate f i l = evaluateLayer f (f i) l

  -- The view defined earlier allows us to pattern on the runtime irrelevant
  -- proof that the layer describes a terminating computation and therefore
  -- define `evaluateLayer` in a way that is purely structural.
  -- This becomes obvious if one spells out the (forced) pattern corresponding
  -- to `d` in each branch of the case.
  evaluateLayer f d l = case view d l of
    TView o => o
    AView j jprf k kprf => evaluateLayer f (k (evaluate f j jprf)) kprf

  ||| If a function's domain is total then it is a pure function.
  public export
  totally : (f : PiG a b) -> (0 _ : (i : a) -> Domain f i) ->
            (i : a) -> b i
  totally f dom i = evaluate f i (dom i)

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

  ||| Domain is a singleton type
  export
  irrelevantDomain : (f : PiG a b) -> (i : a) -> (p, q : Domain f i) -> p === q

  ||| Layer is a singleton type
  irrelevantLayer
    : (f : PiG a b) -> (d : General a b (b i)) -> (l, m : Layer f d) -> l === m

  irrelevantDomain f i p q = irrelevantLayer f (f i) p q

  irrelevantLayer f (Tell o)
    (MkTell o) (MkTell o) = Refl
  irrelevantLayer f (Ask j k)
    (MkAsk j jprf1 k kprf1) (MkAsk j jprf2 k kprf2)
    with (irrelevantDomain f j jprf1 jprf2)
      irrelevantLayer f (Ask j k)
        (MkAsk j jprf k kprf1) (MkAsk j jprf k kprf2)
        | Refl = cong (MkAsk j jprf k)
               $ irrelevantLayer f (k (evaluate f j jprf)) kprf1 kprf2

  ||| The result of `evaluateLayer` does not depend on the specific proof that
  ||| `i` is in the domain of the layer of computation at hand.
  export
  evaluateLayerIrrelevance
    : (f : PiG a b) -> (d : General a b (b i)) -> (0 p, q : Layer f d) ->
      evaluateLayer f d p === evaluateLayer f d q
  evaluateLayerIrrelevance f d p q
    = rewrite irrelevantLayer f d p q in Refl

  ||| The result of `evaluate` does not depend on the specific proof that `i`
  ||| is in the domain of the function at hand.
  export
  evaluateIrrelevance
    : (f : PiG a b) -> (i : a) -> (0 p, q : Domain f i) ->
      evaluate f i p === evaluate f i q
  evaluateIrrelevance f i p q
    = evaluateLayerIrrelevance f (f i) p q

  ||| The result computed by a total function is independent from the proof
  ||| that it is total.
  export
  totallyIrrelevance
    : (f : PiG a b) -> (0 p, q : (i : a) -> Domain f i) ->
      (i : a) -> totally f p i === totally f q i
  totallyIrrelevance f p q i = evaluateIrrelevance f i (p i) (q i)


module GenericFinal

interface Symantics (rep : Type -> Type) where
  int : rep Int
  bool : rep Bool
  tuple : rep a -> rep b -> rep (a, b)
  list : rep a -> rep (List a)
  maybe : rep a -> rep (Maybe a)

data Printer : Type -> Type where
  P : (a -> String) -> Printer a

Symantics Printer where
  int = P (\x => show x)
  bool = P (\x => show x)
  tuple (P f) (P g) = P (\(x, y) => "(" ++ (f x) ++ ", " ++ (g y) ++ ")")
  list (P f) = P (\xs => let res = foldr (\elem, acc => if acc == "" then f elem else (f elem) ++ ", " ++ acc) "" xs in "[" ++ res ++ "]")
  maybe (P f) = P p
    where
      p : Maybe a -> String
      p Nothing = "Nothing"
      p (Just x) = "Just " ++ f x

print : Printer a -> a -> String
print (P f) = f

example : (List Int, Maybe Bool) -> String
example = print (tuple (list int) (maybe bool))


module Flexidisc.OrdList.Disjoint

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

%default total
%access public export

||| A proof that two `OrdList` don't share a key.
data Disjoint : (left, right : OrdList k v o) -> Type where
  ||| The empty `OrdList` is always `Disjoint` from another `OrdList`
  Nil : Disjoint [] right
  ||| A key in the first `OrdList` is fresh in the second `OrdList`.
  (::) : DecEq l => {k : l} -> IsFresh k right -> Disjoint left right ->
                    Disjoint ((k,v) :: left) right

%name Disjoint djt, dis, prf

freshInMerge : Fresh l left -> Fresh l right -> Fresh l (merge left right)
freshInMerge [] freshR = freshR
freshInMerge (f :: fresh) [] = f :: fresh
freshInMerge (f :: fresh) (g :: prf)
  {left = ((ll, tl) :: xs)} {right = ((lr, tr) :: hs)} with (ll < lr)
  | True  = f :: freshInMerge fresh (g :: prf)
  | False = g :: freshInMerge (f :: fresh) prf

invertFresh : Disjoint left ((lr, ty)::right) -> Fresh lr left
invertFresh [] = []
invertFresh (fresh :: djt) =
  (\(f :: _) => f . sym) (getProof fresh) :: invertFresh djt

disjointSmallerRight : Disjoint left (r::right) -> Disjoint left right
disjointSmallerRight [] = []
disjointSmallerRight (fresh :: djt) =
  tailIsFresh fresh :: disjointSmallerRight djt

disjointNub : Disjoint left right -> Nub left -> Nub right ->
              Nub (merge left right)
disjointNub djt [] z = z
disjointNub djt (yes :: x) [] = yes :: x
disjointNub (fll :: djt) (yes :: x) (prf :: w)
  {left = ((ll, tl) :: xs)} {right = ((lr, tr) :: hs)} with (ll < lr)
  | True  = freshInMerge yes (getProof fll) :: disjointNub djt x (prf :: w)
  | False = freshInMerge (invertFresh (fll :: djt)) prf
              :: disjointNub (disjointSmallerRight (fll :: djt)) (yes :: x) w


module TypFunktionen

NatOderString : Bool -> Type
NatOderString False = Nat
NatOderString True = String

natOrString : (b:Bool) -> NatOderString b
natOrString False = 42
natOrString True = "Frage"

toString : (b:Bool) -> NatOderString b -> String
toString False n = show n
toString True s = s


module Effekt.IteratedStaged

import Effekt.CpsStaged
import Effekt.IteratedUnstaged

STM : List Type -> Type -> Type
STM [] a = Exp a
STM (r :: rs) a = (Exp a -> STM rs r) -> STM rs r

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

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

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

(>>=) : STM rs a -> (Exp a -> STM rs b) -> STM rs b
(>>=) = bind

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

shift0 : ((Exp a -> STM rs r) -> STM rs r) -> STM (r :: rs) a
shift0 = id

runIn0 : STM (r :: rs) a -> (Exp a -> STM rs r) -> STM rs r
runIn0 = id

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

mutual
  reify : STM rs a -> Exp (Stm rs a)
  reify {rs = []} m = m
  reify {rs = (q :: qs)} m =
    (Lam $ \ k =>  reify (m (\a => reflect {a = q} {rs = qs} (App k  a))))

  reflect : Exp (Stm rs a) -> STM rs a
  reflect {rs = []} m = m
  reflect {rs = (q :: qs)} m =
    \k => reflect (App m  ((Lam $ \ a =>  reify (k a))))

emit : Exp Int -> STM (List Int :: rs) ()
emit {rs} a = shift0 (\c => do
  as <- c Uni
  pure {rs} (Con a as))

emitTwice : Exp Int -> STM (List Int :: List Int :: rs) ()
emitTwice {rs} a =
  bind {rs=List Int::List Int::rs} (emit {rs=List Int::rs} a) (\u =>
  lift {r=List Int} {rs=List Int::rs} (emit a))

export
reifiedEmitTwice : Exp (Int -> Stm [List Int,List Int] ())
reifiedEmitTwice = Lam (\x => reify {rs=[List Int,List Int]} (emitTwice x))

export
reifiedEmitTwice' : Exp (Int -> Stm [List Int,List Int,()] ())
reifiedEmitTwice' = Lam (\x => reify {rs=[List Int,List Int,()]} (emitTwice {rs=[()]} x))