||| UTC
|||
||| UTC is time as measured by a clock, corrected to keep pace with the earth by adding or removing
||| occasional seconds, known as \"leap seconds\".
||| These corrections are not predictable and are announced with six month's notice.
||| No table of these corrections is provided, as any program compiled with it would become
||| out of date in six months.
|||
||| If you don't care about leap seconds, use 'UTCTime' and 'NominalDiffTime' for your clock calculations,
||| and you'll be fine.

module Data.Time.Clock.Internal.UTCTime

import Data.Time.Clock.Internal.DiffTime
import Data.Time.Calendar.Days

||| This is the simplest representation of UTC.
||| It consists of the day number, and a time offset from midnight.
||| Note that if a day has a leap second added to it, it will have 86401 seconds.
public export
record UTCTime where
  constructor MkUTCTime
  ||| utctDay the day
  utctDay : Day
  |||  utctDayTime the time from midnight, 0 <= t < 86401s (because of leap-seconds)
  utctDayTime : DiffTime

-- instance NFData UTCTime where
--     rnf (UTCTime d t) = rnf d `seq` rnf t `seq` ()

Eq UTCTime where
  (MkUTCTime da ta) == (MkUTCTime db tb) = (da == db) && (ta == tb)

Ord UTCTime where
  compare (MkUTCTime da ta) (MkUTCTime db tb) =
    case (compare da db) of
         EQ => compare ta tb
         cmp => cmp


module Data.Prim.Char

import public Control.WellFounded
import public Data.DPair
import public Data.Prim.Ord

%default total

unsafeRefl : a === b
unsafeRefl = believe_me (Refl {x = a})

--------------------------------------------------------------------------------
--          (<)
--------------------------------------------------------------------------------

||| Witness that `m < n === True`.
export
data (<) : (m,n : Char) -> Type where
  LT : {0 m,n : Char} -> (0 prf : (m < n) === True) -> m < n

||| Contructor for `(<)`.
|||
||| This can only be used in an erased context.
export %hint
0 mkLT : (0 prf : (m < n) === True) -> m < n
mkLT = LT

||| Extractor for `(<)`.
|||
||| This can only be used in an erased context.
export
0 runLT : m < n -> (m < n) === True
runLT (LT prf) = prf

||| We don't trust values of type `(<)` too much,
||| so we use this when creating magical results.
export
strictLT : (0 p : m < n) -> Lazy c -> c
strictLT (LT prf) x = x

--------------------------------------------------------------------------------
--          Aliases
--------------------------------------------------------------------------------

||| Flipped version of `(<)`.
public export
0 (>) : (m,n : Char) -> Type
m > n = n < m

||| `m <= n` mean that either `m < n` or `m === n` holds.
public export
0 (<=) : (m,n : Char) -> Type
m <= n = Either (m < n) (m === n)

||| Flipped version of `(<=)`.
public export
0 (>=) : (m,n : Char) -> Type
m >= n = n <= m

||| `m /= n` mean that either `m < n` or `m > n` holds.
public export
0 (/=) : (m,n : Char) -> Type
m /= n = Either (m < n) (m > n)

--------------------------------------------------------------------------------
--          Order
--------------------------------------------------------------------------------

0 ltNotEQ : m < n -> Not (m === n)
ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ")

0 ltNotGT : m < n -> Not (n < m)
ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT")

0 eqNotLT : m === n -> Not (m < n)
eqNotLT = flip ltNotEQ

export
comp : (m,n : Char) -> Trichotomy (<) m n
comp m n = case prim__lt_Char m n of
  0 => case prim__eq_Char m n of
    0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl)
    x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl)
  x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl)

export
Total Char (<) where
  trichotomy   = comp
  transLT p q  = strictLT p $ strictLT q $ LT unsafeRefl

--------------------------------------------------------------------------------
--          Bounds and Well-Foundedness
--------------------------------------------------------------------------------

||| Lower bound of `Char`
public export
MinChar : Char
MinChar = '\x0000'

||| `m >= MinChar` for all `m` of type `Char`.
export
0 GTE_MinChar : (m : Char) -> m >= MinChar
GTE_MinChar m = case comp MinChar m of
  LT x f g => %search
  EQ f x g => %search
  GT f g x => assert_total $ idris_crash "IMPOSSIBLE: Char smaller than 0"

||| Not value of type `Char` is less than `MinChar`.
export
0 Not_LT_MinChar : m < MinChar -> Void
Not_LT_MinChar = GTE_not_LT (GTE_MinChar m)

||| Every value of type `Char` is accessible with relation
||| to `(<)`.
export
accessLT : (m : Char) -> Accessible (<) m
accessLT m = Access $ \n,lt => accessLT (assert_smaller m n)

||| `(<)` is well founded.
export %inline
WellFounded Char (<) where
  wellFounded = accessLT


||| Rules for stacking
||| Section 5
module Bautzen.Game.Stacking

import Bautzen.GameUnit
import Bautzen.Terrain

-- section 5.1

stackingPoints : Nation -> UnitSize -> UnitType -> Nat
stackingPoints   n         s           SupplyColumn = 1
stackingPoints   n         Regiment    t            = 2
stackingPoints   n         Brigade     t            = 3
stackingPoints   n         Division    HQ           = 3
stackingPoints   Russian   Corps       HQ           = 3
stackingPoints   Russian   Army        HQ           = 3
stackingPoints   n         Corps       Armored      = 3  -- 1KP
stackingPoints   _         _           _            = 1  -- WTF?

-- section 5.2

stackingLimit : Terrain -> Nat
stackingLimit Clear               = 6
stackingLimit Wood                = 4
stackingLimit Rough               = 4
stackingLimit RoughWood           = 4
stackingLimit (Hill base)         = stackingLimit base
stackingLimit (Village base)      = stackingLimit base
stackingLimit Town                = 6
stackingLimit (SupplySource base) = stackingLimit base

-- section 5.4, 5.5, 5.6

data Stacking : Type where
  Stacked : (n : Nat) -> Stacking
  Overstacked : (n : Nat) -> Stacking
  CannotStack : Stacking

||| What's the stacking status of `units` on `terrain`?
||| This can be used to test incrementally the stacking of adding one unit to
||| to an existing stack too.
||| @units a lits of units to check stacking of.
||| @terrain the terrain of the `Hex` the units are stacked on.
stacking : (units : List GameUnit) -> (terrain: Terrain) -> Stacking
stacking units terrain =
  if moreThan2DifferentFormations || unitsFromDifferentNations
  then CannotStack
  else let sp = sum $ map sps units
       in if sp <= stackingLimit terrain
          then Stacked sp
          else Overstacked sp
  where
    unitsFromDifferentNations : Bool
    unitsFromDifferentNations = (length . nub . map nation $ units) > 1

    moreThan2DifferentFormations : Bool
    moreThan2DifferentFormations = (length . catMaybes . nub . map parent $ units) > 2

    sps : GameUnit -> Nat
    sps (MkGameUnit nation unitType name parent size move currentMP hit combat) = stackingPoints nation size unitType

namespace StackingTest

  stacking_of_a_single_unit : stacking [ GameUnit.p13_5dp ] Clear = Stacked 2
  stacking_of_a_single_unit = Refl

  stacking_of_more_units_from_same_parent : stacking [ GameUnit.p13_5dp, GameUnit.p15_5dp, GameUnit.p17_5dp ] Clear = Stacked 6
  stacking_of_more_units_from_same_parent = Refl

  overstack_from_units_from_same_parent : stacking [ GameUnit.p13_5dp, GameUnit.p15_5dp, GameUnit.p5dp ] Clear = Overstacked 7
  overstack_from_units_from_same_parent = Refl

  cannot_stack_more_than_1_unit_from_different_parent : stacking [ GameUnit.p13_5dp, GameUnit.p33_7dp, GameUnit.p32_8dp ] Clear = CannotStack
  cannot_stack_more_than_1_unit_from_different_parent = Refl

  can_stack_independent_units : stacking [ GameUnit.p13_5dp, GameUnit.p33_7dp, GameUnit.p6l ] Clear = Overstacked 7
  can_stack_independent_units = Refl

  cannot_stack_units_from_different_nations : stacking [ GameUnit.p13_5dp, GameUnit.r857_294 ] Clear = CannotStack
  cannot_stack_units_from_different_nations = Refl


module Examples

import Data.Vect
import ProcessLib
import Proto
import HoriComp
import VertComp
import Primitives
import SumWire
import Dualise
import SumWire
import CupCap
import Util

%flag C "-O3"

gt5: Hom [Down Int] [Down Int, Down Int]
gt5 = mkPure "gt5: " (\n => if n > 5 then Left n else Right n) -*- splitEither

inc: Hom [Down Int] [Down Int]
inc = mkPure "inc: " (\i => i + 1)

downIntWire: Hom [Down Int] [Down Int]
downIntWire = mkPure "down int: " id

upIntWire: Hom [Up Int] [Up Int]
upIntWire = dualise downIntWire

myProc: Hom [Down Int] []
myProc =     downIntWire + cap
         -*- (splice -*- inc -*- gt5) + upIntWire
         -*- downPrinter + cup

test: Client ()
test = do Just proc <- Spawn myProc | _ => Action (putStrLn "failed to spawn the process")
          val_resp <- Request proc (Val (TopInWire Here) 1)
          Action $ putStrLn $ "result: " ++ show val_resp
          Util.dot_sleeper 20

namespace Main
  main: IO ()
  main = runProc test


||| Primitive monadic (non-transformer) parser
module Util.MiniParser
import Data.Vect

%default total
%access public export

data Parser a = P (String -> Either String (a, String))

parse :  Parser a -> String -> Either String (a, String)
parse (P f) str = f str

parseAll : Parser a -> String -> Either String a
parseAll p str = do
          (xa, rst) <- parse p str
          if rst == ""
          then Right xa
          else Left ("did not parse " ++ rst)

onechar : Parser Char
onechar = P (\inp => case strM inp of
                    StrNil => Left "Error! Parsing empty list."
                    StrCons x xs => Right (x, xs))

interface Parsable a where
  item : Parser a

Parsable Char where
   item = onechar

interface Parsable a => Composite b a where
   compose : List a -> b

Composite String Char where
   compose = pack

Functor Parser where
  map f p = P (\inp => case parse p inp of
                          Left err        => Left err
                          Right (v, rest) => Right ((f v), rest))

Applicative Parser where
  pure v  = P (\inp => Right (v, inp))
  a <*> b = P (\inp => do (f, rest ) <- parse a inp
                          (x, rest') <- parse b rest
                          pure ((f x), rest'))

Monad Parser where
  p >>= f = P (\inp => case parse p inp of
                         Left err       => Left err
                         Right (v,rest) => parse (f v) rest)

||| choice of parsers
Alternative Parser where
  empty   = P (const (Left "empty"))
  p <|> q = P (\inp => case parse p inp of
                         Left msg      => parse q inp
                         Right (v,out) => Right (v,out))

fail : String -> Parser a
fail msg = P (\_ => Left msg)

infix 0 <?>
||| similar to parsec allows to specify failure message
(<?>) : Parser a -> String -> Parser a
(<?>) p s = p <|> fail s

-- basic char parsers

accept : Parsable a => (a -> Bool) -> Parser a
accept f = do
         x <- item
         if (f x)
         then pure x
         else empty

digit : Parser Char
digit = accept isDigit

lower : Parser Char
lower = accept isLower

upper : Parser Char
upper = accept isUpper

letter : Parser Char
letter = accept isAlpha

char : Char -> Parser Char
char c = accept (c ==)

charIngoreCase : Char -> Parser Char
charIngoreCase c = accept ((toUpper c) ==) <|> accept ((toLower c) ==)

string : String -> Parser String
string s = map pack (traverse char (unpack s))

stringIngoreCase : String -> Parser String
stringIngoreCase s = map pack (traverse charIngoreCase (unpack s))

-- combinators

oneof : (Parsable a, Eq a) => List a -> Parser a
oneof xs = accept (\x => elem x xs)

optional : Parser a -> Parser (Maybe a)
optional p = map Just p <|> pure Nothing

notFollowedBy : Parser a -> Parser ()
notFollowedBy p = do
          a <- optional p
          case a of
            Nothing => pure ()
            Just x => fail "not empty"

eof : Parser ()
eof = notFollowedBy onechar

||| apply p only if q is not applicable
unless :  Parser a -> Parser a -> Parser a
unless q p = P (\inp => case parse q inp of
                        (Left _)  => parse p inp
                        (Right _) => Left "unless failed"
               )

exactly :  (n : Nat) -> Parser a  -> Parser (Vect n a)
exactly Z _      = pure Nil
exactly (S n) p = [| p :: exactly n p |]

covering
many : Parsable a => Parser a -> Parser (List a)
many p = do
  (Just i) <- optional p
    | Nothing => pure Nil
  [| pure i :: many p |]

covering
many1 : Parsable a => Parser a -> Parser (List a)
many1 p = do
    _ <- p
    many p

covering
spaces : Parser (List Char)
spaces = many1 (char ' ')

covering
until : Parser a -> Parser a -> Parser (List a)
until to p = map reverse (untilrec to p Nil)
   where
    partial
    untilrec : Parser a -> Parser a -> List a -> Parser (List a)
    untilrec to p xa = do
               i <- optional to
               case i of
                 Just _ => pure xa
                 Nothing => do
                   a <- p
                   untilrec to p (a :: xa)

covering
between : (Parsable a, Composite b a) => Parser a -> Parser a -> Parser b
between from to = do
        fx <- from
        as <- until to item
        pure (compose as)

covering
stringbetween : Parser Char -> Parser Char -> Parser String
stringbetween = between

-- primitive parsers

covering
decimalInt : Parser Int
decimalInt = many digit >>= pure . cast . pack

covering
decimalInteger : Parser Integer
decimalInteger = many digit >>= pure . cast . pack


module Control.Optics.Lens

import public Control.Optics.Types

export
lens : (prj : s -> a) -> (inj : s -> b -> t) -> Lens s t a b
lens prj inj (Mor f) = Mor (\s => inj s <$> f (prj s))


module FTCQueue

-- Based on http://okmij.org/ftp/Haskell/AlgorithmsH1.html#FTCQueue
%access public export

data FTCQueue : (r : Type -> Type -> Type) -> Type -> Type -> Type where
  Leaf : r a b -> FTCQueue r a b
  Node : FTCQueue r a x -> FTCQueue r x b -> FTCQueue r a b

tsingleton : r a b -> FTCQueue r a b
tsingleton r = Leaf r

infixl 9 |>
(|>) : FTCQueue r a x -> r x b -> FTCQueue r a b
t |> r = Node t (Leaf r)

infixl 9 ><
(><) : FTCQueue r a x -> FTCQueue r x b -> FTCQueue r a b
t1 >< t2 = Node t1 t2

infixl 9 :|
data ViewL : (r : Type -> Type -> Type) -> Type -> Type -> Type where
  TOne  : r a b -> ViewL r a b
  (:|)  : r a x -> FTCQueue r x b -> ViewL r a b

tviewl : FTCQueue r a b -> ViewL r a b
tviewl (Leaf r) = TOne r
tviewl (Node t1 t2) = go t1 t2
 where
   go : FTCQueue r a x -> FTCQueue r x b -> ViewL r a b
   go (Leaf r) tr = r :| tr
   go (Node tl1 tl2) tr = go tl1 (Node tl2 tr)


||| Switching Combinators
|||
||| Switches allow us to dynamically change the structure
||| (wiring) of a running network of stream functions.
||| Semantically, the react on discrete events, but
||| some of the switching primitives in this module use
||| the `Either` data type if it allows us to more exactly
||| describe the semantics of a switch.
module Data.MSF.Switch

import Data.MSF.Core
import Data.MSF.Event
import Data.MSF.Running
import Data.MSF.Util
import Data.SOP

%default total

--------------------------------------------------------------------------------
--          Immediate Switches
--------------------------------------------------------------------------------

||| Produces output of the first MSF until it produces
||| a `Left`, in which case the event will be used to
||| create a new MSF, which will be immediately evaluated
||| and used henceforth.
|||
||| This is a one-time switch, which is often used to
||| run an MSF a fixed number of times or until a certain
||| event occurs, after which the replacement will be used.
|||
||| Note: It is unsafe to use this in a recursive setting,
|||       as it would allow us to create an infinite loop
|||       of streaming functions, all of which return `Left`s
|||       forever. Luckily, the totality checker will prevent us
|||       from doing this.
export %inline
switchE : MSF m i (Either e o) -> (e -> MSF m i o) -> MSF m i o
switchE = Switch

||| Produces output of the given MSF until it fires an event,
||| in which case a new MSF is created,
||| which will be evaluated immediately and used henceforth.
|||
||| This uses `switchE` internally, so all restrictions mentioned
||| there apply.
export
switch :  MSF m i (NP I [o, Event e])
       -> (e -> MSF m i o)
       -> MSF m i o
switch sf = switchE $ sf >>^ (\[vo,ve] => event (Right vo) Left ve)

--------------------------------------------------------------------------------
--          Delayed Switches
--------------------------------------------------------------------------------

rswUtil : NP I [o,Event x] -> Either (x,o) o
rswUtil [vo,Ev vx] = Left (vx,vo)
rswUtil [vo,NoEv]  = Right vo

||| Produces output of the given MSF until it fires an event,
||| in which case a new MSF is created,
||| which will be used in all further evaluation steps.
export
dSwitch : MSF m i (NP I [o, Event e]) -> (e -> MSF m i o) -> MSF m i o
dSwitch sf = switch (sf >>> par [id, iPre NoEv])

--------------------------------------------------------------------------------
--          Recurring Switches
--------------------------------------------------------------------------------

export %inline
rSwitch : Monad m => MSF m i o -> MSF m (NP I [Event $ MSF m i o,i]) o
rSwitch sf =
  feedback sf . arrM $
    \[sf,[ev,vi]] => do
      (vo,sf2) <- step (fromEvent sf ev) vi
      pure [sf2,vo]

export %inline
drSwitch : Monad m => MSF m i o -> MSF m (NP I [Event $ MSF m i o,i]) o
drSwitch sf =
  feedback sf . arrM $
    \[sf,[ev,vi]] => do
      (vo,sf2) <- step sf vi
      pure [fromEvent sf2 ev,vo]

||| Produces output of the first MSF until the second
||| fires an event, in which case a new MSF is created,
||| which will be used in all futre evaluation cycles.
export
drswitchWhen :  Monad m
             => MSF m i o
             -> MSF m i (Event e)
             -> (e -> MSF m i o)
             -> MSF m i o
drswitchWhen ini es f = fan [es >>^ map f,id] >>> drSwitch ini


module Data.Trifunctor

%default total
%access public export

||| Trifunctor is abstraction over type with 3 type parameters
||| Progression of abstractions: Functor => Bifunctor => Trifunctor
interface Trifunctor (t : Type -> Type -> Type -> Type) where
  timap : (r -> rr) -> (e -> ee) -> (a -> aa) -> t r e a -> t rr ee aa

  bimap : (e -> ee) -> (a -> aa) -> t r e a -> t r ee aa
  bimap = timap id

  map : (a -> aa) -> t r e a -> t r e aa
  map = timap id id

  mapLeft : (e -> ee) -> t r e a -> t r ee a
  mapLeft e = timap id e id


module StlcProp

import Expr
import Logic
import Maps
import Stlc

%access public export

%default total

cannonical_forms_bool : HasType Maps.empty t TyBool -> Value t ->
                        Either (t = Tru) (t = Fls)
cannonical_forms_bool (T_Var _) V_Abs impossible
cannonical_forms_bool (T_Abs _) V_Abs impossible
cannonical_forms_bool (T_App _ _) V_Abs impossible
cannonical_forms_bool T_Tru V_Abs impossible
cannonical_forms_bool T_Fls V_Abs impossible
cannonical_forms_bool (T_Test _ _ _) V_Abs impossible
cannonical_forms_bool _ V_Tru = Left Refl
cannonical_forms_bool _ V_Fls = Right Refl

cannonical_forms_fun : HasType Maps.empty t (TyArrow ty1 ty2) -> Value t ->
                       (x : Id ** u : Tm ** t = Abs x ty1 u)
cannonical_forms_fun (T_Abs {t12} ty) (V_Abs {x}) = (x ** t12 ** Refl)
cannonical_forms_fun (T_Var _) V_Tru impossible
cannonical_forms_fun (T_Abs _) V_Tru impossible
cannonical_forms_fun (T_App _ _) V_Tru impossible
cannonical_forms_fun T_Tru V_Tru impossible
cannonical_forms_fun T_Fls V_Tru impossible
cannonical_forms_fun (T_Test _ _ _) V_Tru impossible
cannonical_forms_fun (T_Var _) V_Fls impossible
cannonical_forms_fun (T_Abs _) V_Fls impossible
cannonical_forms_fun (T_App _ _) V_Fls impossible
cannonical_forms_fun T_Tru V_Fls impossible
cannonical_forms_fun T_Fls V_Fls impossible
cannonical_forms_fun (T_Test _ _ _) V_Fls impossible

progress : HasType Maps.empty t ty -> Either (Value t) (t' : Tm ** (t -+> t'))
progress (T_Var prf) = absurd prf
progress (T_Abs _) = Left V_Abs
progress (T_App ht1 ht2) = case progress ht1 of
  Left v1 => case progress ht2 of
    Left v2 => let (x ** u ** prf) = cannonical_forms_fun ht1 v1
               in rewrite prf
               in Right (subst x _ u ** ST_AppAbs v2)
    Right (t2 ** s2) => Right (App _ t2 ** ST_App2 v1 s2)
  Right (t1 ** s1) => Right (App t1 _ ** ST_App1 s1)
progress T_Tru = Left V_Tru
progress T_Fls = Left V_Fls
progress (T_Test {t2} {t3} ht1 ht2 ht3) = case progress ht1 of
  Left v1 => case cannonical_forms_bool ht1 v1 of
    Left prf => rewrite prf
                in Right (t2 ** ST_TestTru)
    Right prf => rewrite prf
                 in Right (t3 ** ST_TestFls)
  Right (t1' ** s1) => Right (Test t1' t2 t3 ** ST_Test s1)

data AppearsFreeIn : Id -> Tm -> Type where
  AFI_Var : AppearsFreeIn x (Var x)
  AFI_App1 : AppearsFreeIn x t1 -> AppearsFreeIn x (App t1 t2)
  AFI_App2 : AppearsFreeIn x t2 -> AppearsFreeIn x (App t1 t2)
  AFI_Abs : Not (y = x) -> AppearsFreeIn x t -> AppearsFreeIn x (Abs y ty t)
  AFI_Test1 : AppearsFreeIn x t1 -> AppearsFreeIn x (Test t1 t2 t3)
  AFI_Test2 : AppearsFreeIn x t2 -> AppearsFreeIn x (Test t1 t2 t3)
  AFI_Test3 : AppearsFreeIn x t3 -> AppearsFreeIn x (Test t1 t2 t3)

Closed : (t : Tm) -> Type
Closed t = (x : Id) -> Not (AppearsFreeIn x t)

free_in_context : AppearsFreeIn x t -> HasType gamma t ty ->
                  (ty' : Ty ** gamma x = Just ty')
free_in_context {ty} AFI_Var (T_Var prf) = (ty ** prf)
free_in_context (AFI_App1 afi) (T_App ht1 _) = free_in_context afi ht1
free_in_context (AFI_App2 afi) (T_App _ ht2) = free_in_context afi ht2
free_in_context {x} {gamma} (AFI_Abs contra afi) (T_Abs {ty11} ht) =
  let (ty' ** prf) = free_in_context afi ht
  in (ty' ** replace {P=\r => (if r then Just ty11 else gamma x) = Just ty'}
                     (snd beq_id_false_iff contra)
                     prf)
free_in_context (AFI_Test1 afi) (T_Test ht1 _ _) = free_in_context afi ht1
free_in_context (AFI_Test2 afi) (T_Test _ ht2 _) = free_in_context afi ht2
free_in_context (AFI_Test3 afi) (T_Test _ _ ht3) = free_in_context afi ht3

typeable_empty__closed : HasType Maps.empty t ty -> Closed t
typeable_empty__closed (T_Var prf) = absurd prf
typeable_empty__closed (T_Abs {ty11} ht) = \x, afi => case afi of
  AFI_Abs contra afi => let (ty' ** prf) = free_in_context afi ht
                        in uninhabited (replace {P=\r => (if r
                                                             then Just ty11
                                                             else Nothing)
                                                         = Just ty'}
                                                (snd beq_id_false_iff contra)
                                                prf)
typeable_empty__closed (T_App ht1 ht2) = \_, afi => case afi of
  AFI_App1 afi => let (_ ** prf) = free_in_context afi ht1
                  in uninhabited prf
  AFI_App2 afi => let (_ ** prf) = free_in_context afi ht2
                  in uninhabited prf
typeable_empty__closed T_Tru = \_, afi => case afi of
  AFI_Var impossible
  (AFI_App1 _) impossible
  (AFI_App2 _) impossible
  (AFI_Abs _ _) impossible
  (AFI_Test1 _) impossible
  (AFI_Test2 _) impossible
  (AFI_Test3 _) impossible
typeable_empty__closed T_Fls = \_, afi => case afi of
  AFI_Var impossible
  (AFI_App1 _) impossible
  (AFI_App2 _) impossible
  (AFI_Abs _ _) impossible
  (AFI_Test1 _) impossible
  (AFI_Test2 _) impossible
  (AFI_Test3 _) impossible
typeable_empty__closed (T_Test ht1 ht2 ht3) = \_, afi => case afi of
  AFI_Test1 afi => let (_ ** prf) = free_in_context afi ht1
                   in uninhabited prf
  AFI_Test2 afi => let (_ ** prf) = free_in_context afi ht2
                   in uninhabited prf
  AFI_Test3 afi => let (_ ** prf) = free_in_context afi ht3
                   in uninhabited prf

context_invariance : HasType gamma t ty ->
                     ((x : Id) -> AppearsFreeIn x t -> gamma x = gamma' x) ->
                     HasType gamma' t ty
context_invariance (T_Var {x} prf) f = T_Var (rewrite sym (f x AFI_Var) in prf)
context_invariance {gamma} {gamma'} (T_Abs {x=y} {ty11} {t12} ht) f =
  T_Abs (context_invariance ht f')
where f' : (z : Id) -> AppearsFreeIn z t12 ->
           (update y ty11 gamma) z = (update y ty11 gamma') z
      f' z afi with (decEq y z)
        f' z afi | Yes prf = rewrite snd beq_id_true_iff prf in Refl
        f' z afi | No contra = rewrite snd beq_id_false_iff contra
                               in f z (AFI_Abs contra afi)
context_invariance {gamma} {gamma'} (T_App {t1} {t2} ht1 ht2) f =
  T_App (context_invariance ht1 f1) (context_invariance ht2 f2)
where f1 : (y : Id) -> AppearsFreeIn y t1 -> gamma y = gamma' y
      f1 y afi = f y (AFI_App1 afi)
      f2 : (y : Id) -> AppearsFreeIn y t2 -> gamma y = gamma' y
      f2 y afi = f y (AFI_App2 afi)
context_invariance T_Tru _ = T_Tru
context_invariance T_Fls _ = T_Fls
context_invariance {gamma} {gamma'} (T_Test {t1} {t2} {t3} ht1 ht2 ht3) f =
  T_Test (context_invariance ht1 f1)
         (context_invariance ht2 f2)
         (context_invariance ht3 f3)
where f1 : (y : Id) -> AppearsFreeIn y t1 -> gamma y = gamma' y
      f1 y afi = f y (AFI_Test1 afi)
      f2 : (y : Id) -> AppearsFreeIn y t2 -> gamma y = gamma' y
      f2 y afi = f y (AFI_Test2 afi)
      f3 : (y : Id) -> AppearsFreeIn y t3 -> gamma y = gamma' y
      f3 y afi = f y (AFI_Test3 afi)

substitution_preserves_typing : HasType (Maps.update x ty2 gamma) t ty ->
                                HasType Maps.empty v ty2 ->
                                HasType gamma (subst x v t) ty
substitution_preserves_typing {x} {ty2} {ty} {gamma} {t = Var y} (T_Var prf) htv
  with (decEq x y)
  substitution_preserves_typing {x} {ty2} {ty} {gamma} {t = Var y}
                                (T_Var prf) htv | Yes prf' =
    let ty2_eq_ty = justInjective
                      (replace
                        {P=\r => (if r then Just ty2 else gamma y) = Just ty}
                        (snd beq_id_true_iff prf')
                        prf)
    in rewrite sym ty2_eq_ty
    in context_invariance htv (\z, afi =>
                                absurd (typeable_empty__closed htv z afi))
  substitution_preserves_typing {x} {ty2} {ty} {gamma} {t = Var y}
                                (T_Var prf) htv | No contra =
    T_Var (replace {P=\r => (if r then Just ty2 else gamma y) = Just ty}
                   (snd beq_id_false_iff contra) prf)
substitution_preserves_typing (T_App ht1 ht2) htv =
  T_App (substitution_preserves_typing ht1 htv)
        (substitution_preserves_typing ht2 htv)
substitution_preserves_typing {x} {ty2} {gamma} {t = Abs y ty t}
                              (T_Abs {ty12} ht) htv with (decEq x y)
    substitution_preserves_typing {x} {ty2} {gamma} {t = Abs y ty t}
                                  (T_Abs {ty12} ht) htv | Yes prf =
      let ht' = replace
                  {P=\r => HasType r t ty12}
                  (update_shadow {x=y} {v2=ty} {v1=ty2} {m=gamma})
                  (replace
                    {P=\r => HasType (\y1 => if beq_id y y1
                                                then Just ty
                                                else if beq_id r y1
                                                     then Just ty2
                                                     else gamma y1)
                                     t
                                     ty12}
                    prf
                    ht)
      in T_Abs ht'
    substitution_preserves_typing {x} {ty2} {gamma} {t = Abs y ty t}
                                  (T_Abs {ty12} ht) htv | No contra =
      T_Abs (substitution_preserves_typing
              (context_invariance
                ht
                (\z, afi =>
                  cong {f=\g => g z}
                       (update_permute {v1=ty} {v2=ty2} {m=gamma} contra)))
              htv)
substitution_preserves_typing T_Tru _ = T_Tru
substitution_preserves_typing T_Fls _ = T_Fls
substitution_preserves_typing (T_Test ht1 ht2 ht3) htv =
  T_Test (substitution_preserves_typing ht1 htv)
         (substitution_preserves_typing ht2 htv)
         (substitution_preserves_typing ht3 htv)

preservation : HasType Maps.empty t ty -> t -+> t' -> HasType Maps.empty t' ty
preservation (T_Var prf) _ = absurd prf
preservation (T_Abs ht) s = absurd s
preservation (T_App (T_Abs ht1) ht2) (ST_AppAbs v) =
  substitution_preserves_typing ht1 ht2
preservation (T_App ht1 ht2) (ST_App1 s1) = T_App (preservation ht1 s1) ht2
preservation (T_App ht1 ht2) (ST_App2 v1 s2) = T_App ht1 (preservation ht2 s2)
preservation T_Tru s = absurd s
preservation T_Fls s = absurd s
preservation (T_Test _ ht2 _) ST_TestTru = ht2
preservation (T_Test _ _ ht3) ST_TestFls = ht3
preservation (T_Test ht1 ht2 ht3) (ST_Test s) =
  T_Test (preservation ht1 s) ht2 ht3

subject_expansion : (  t : Tm ** t' : Tm ** ty : Ty
                    ** ( t -+> t'
                       , HasType Maps.empty t' ty
                       , Not (HasType Maps.empty t ty) ))
subject_expansion = (  App (Abs X (TyArrow TyBool TyBool) (Var X)) Tru
                    ** subst X Tru (Var X)
                    ** TyBool
                    ** ( ST_AppAbs V_Tru
                       , T_Tru
                       , \ht => case ht of
                           T_App (T_Abs (T_Var prf)) _ =>
                             uninhabited (justInjective prf) ))

Stuck : (t : Tm) -> Type
Stuck t = (NormalForm Step t, Not (Value t))

soundness : HasType Maps.empty t ty -> t -+>* t' -> Not (Stuck t')
soundness ht MultiRefl (nf, not_value) = case progress ht of
  Left v => not_value v
  Right p => nf p
soundness ht (MultiStep once next) (nf, not_value) =
  soundness (preservation ht once) next (nf, not_value)

unique_types : HasType gamma e ty -> HasType gamma e ty' -> ty = ty'
unique_types (T_Var prf1) (T_Var prf2) = justInjective (trans (sym prf1) prf2)
unique_types (T_Abs ht1) (T_Abs ht2) = rewrite unique_types ht1 ht2 in Refl
unique_types {ty} {ty'} (T_App ht1 ht2) (T_App {ty11=ty2} ht3 ht4) =
  let prf = replace {P=\r => TyArrow r ty = TyArrow ty2 ty'}
                    (unique_types ht2 ht4)
                    (unique_types ht1 ht3)
  in case prf of
    Refl => Refl
unique_types T_Tru T_Tru = Refl
unique_types T_Fls T_Fls = Refl
unique_types (T_Test _ ht1 _) (T_Test _ ht2 _) = unique_types ht1 ht2


module Data.Prim.Bits32

import public Control.WellFounded
import public Data.DPair
import public Data.Prim.Ord
import public Algebra.Solver.Ring
import Syntax.PreorderReasoning

%default total

unsafeRefl : a === b
unsafeRefl = believe_me (Refl {x = a})

--------------------------------------------------------------------------------
--          (<)
--------------------------------------------------------------------------------

||| Witness that `m < n === True`.
export
data (<) : (m,n : Bits32) -> Type where
  LT : {0 m,n : Bits32} -> (0 prf : (m < n) === True) -> m < n

||| Contructor for `(<)`.
|||
||| This can only be used in an erased context.
export %hint
0 mkLT : (0 prf : (m < n) === True) -> m < n
mkLT = LT

||| Extractor for `(<)`.
|||
||| This can only be used in an erased context.
export
0 runLT : m < n -> (m < n) === True
runLT (LT prf) = prf

||| We don't trust values of type `(<)` too much,
||| so we use this when creating magical results.
export
strictLT : (0 p : m < n) -> Lazy c -> c
strictLT (LT prf) x = x

--------------------------------------------------------------------------------
--          Aliases
--------------------------------------------------------------------------------

||| Flipped version of `(<)`.
public export
0 (>) : (m,n : Bits32) -> Type
m > n = n < m

||| `m <= n` mean that either `m < n` or `m === n` holds.
public export
0 (<=) : (m,n : Bits32) -> Type
m <= n = Either (m < n) (m === n)

||| Flipped version of `(<=)`.
public export
0 (>=) : (m,n : Bits32) -> Type
m >= n = n <= m

||| `m /= n` mean that either `m < n` or `m > n` holds.
public export
0 (/=) : (m,n : Bits32) -> Type
m /= n = Either (m < n) (m > n)

--------------------------------------------------------------------------------
--          Order
--------------------------------------------------------------------------------

0 ltNotEQ : m < n -> Not (m === n)
ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ")

0 ltNotGT : m < n -> Not (n < m)
ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT")

0 eqNotLT : m === n -> Not (m < n)
eqNotLT = flip ltNotEQ

export
comp : (m,n : Bits32) -> Trichotomy (<) m n
comp m n = case prim__lt_Bits32 m n of
  0 => case prim__eq_Bits32 m n of
    0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl)
    x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl)
  x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl)

export
Total Bits32 (<) where
  trichotomy   = comp
  transLT p q  = strictLT p $ strictLT q $ LT unsafeRefl

--------------------------------------------------------------------------------
--          Bounds and Well-Foundedness
--------------------------------------------------------------------------------

||| Lower bound of `Bits32`
public export
MinBits32 : Bits32
MinBits32 = 0

||| Upper bound of `Bits32`
public export
MaxBits32 : Bits32
MaxBits32 = 0xffffffff

||| `m >= 0` for all `m` of type `Bits32`.
export
0 GTE_MinBits32 : (m : Bits32) -> m >= MinBits32
GTE_MinBits32 m = case comp MinBits32 m of
  LT x f g => %search
  EQ f x g => %search
  GT f g x => assert_total $ idris_crash "IMPOSSIBLE: Bits32 smaller than 0"

||| Not value of type `Bits32` is less than zero.
export
0 Not_LT_MinBits32 : m < 0 -> Void
Not_LT_MinBits32 = GTE_not_LT (GTE_MinBits32 m)

||| `m <= MaxBits32` for all `m` of type `Bits32`.
export
0 LTE_MaxBits32 : (m : Bits32) -> m <= MaxBits32
LTE_MaxBits32 m = case comp m MaxBits32 of
  LT x f g => %search
  EQ f x g => %search
  GT f g x => assert_total
            $ idris_crash "IMPOSSIBLE: Bits32 greater than \{show MaxBits32}"

||| Not value of type `Bits32` is greater than `MaxBits32`.
export
0 Not_GT_MaxBits32 : m > MaxBits32 -> Void
Not_GT_MaxBits32 = LTE_not_GT (LTE_MaxBits32 m)

||| Every value of type `Bits32` is accessible with relation
||| to `(<)`.
export
accessLT : (m : Bits32) -> Accessible (<) m
accessLT m = Access $ \n,lt => accessLT (assert_smaller m n)

||| `(<)` is well founded.
export %inline
WellFounded Bits32 (<) where
  wellFounded = accessLT

||| Every value of type `Bits32` is accessible with relation
||| to `(>)`.
export
accessGT : (m : Bits32) -> Accessible (>) m
accessGT m = Access $ \n,gt => accessGT (assert_smaller m n)

||| `(>)` is well founded.
export %inline
[GT] WellFounded Bits32 (>) where
  wellFounded = accessGT

--------------------------------------------------------------------------------
--          Arithmetics
--------------------------------------------------------------------------------

||| Safe division.
|||
||| This uses `0 < d` as a constraint instead
||| of `0 /= d`, because in my experience, the former
||| is much more useful.
export %inline
sdiv : (n,d : Bits32) -> (0 prf : 0 < d) => Bits32
sdiv n d = n `div` d

||| Refined division.
|||
||| This comes with a proof that the result is
||| strictly smaller than `n`.
|||
||| This uses `0 < n` as a constraint instead
||| of `0 /= n`, because in my experience, the former
||| is much more useful.
export %inline
rdiv :  (n,d : Bits32)
     -> (0 dgt1 : 1 < d)
     => (0 ngt0 : 0 < n)
     => Subset Bits32 (< n)
rdiv n d = Element (n `div` d) (LT unsafeRefl)

||| Safe modulo.
|||
||| This uses `0 < d` as a constraint instead
||| of `0 /= d`, because in my experience, the former
||| is much more useful.
|||
||| If you need the postcondition that the result is strictly
||| smaller than `d`, use `rmod` instead.
export %inline
smod : (n,d : Bits32) -> (0 prf : 0 < d) => Bits32
smod n d = n `mod` d

||| Refined modulo.
|||
||| This comes with a proof that the result is strictly smaller
||| than `d`.
|||
||| It uses `0 < d` as a constraint instead
||| of `0 /= d`, because in my experience, the former
||| is much more useful.
export %inline
rmod : (n,d : Bits32) -> (0 prf : 0 < d) => Subset Bits32 (< d)
rmod n d = Element (n `mod` d) (LT unsafeRefl)


module Quantities.SIBaseQuantities

import Quantities.Core

%default total
%access public export

Length : Dimension
Length = MkDimension "Length"

Mass : Dimension
Mass = MkDimension "Mass"

Time : Dimension
Time = MkDimension "Time"

ElectricCurrent : Dimension
ElectricCurrent = MkDimension "ElectricCurrent"

-- Thermodynamic temperature
Temperature : Dimension
Temperature = MkDimension "Temperature"

AmountOfSubstance : Dimension
AmountOfSubstance = MkDimension "AmountOfSubstance"

LuminousIntensity : Dimension
LuminousIntensity = MkDimension "LuminousIntensity"


module Examples.Auction

import Data.Vect
import Data.Vect.Quantifiers

import DepSec.Labeled
import DepSec.DIO
import DepSec.Declassification

import Examples.TwoPointLattice

%default total
%access export

--------------------------------------------------------------------------------
--- Auction Hatch Example
--------------------------------------------------------------------------------
Bid : Type
Bid = (String, Nat)

BidLog : Nat -> Type
BidLog n = Vect n (Labeled H Bid)

data MaxL : Bid -> Labeled H Bid -> Type where
  IsMaxL : (b1 : Bid)
        -> (b2 : Labeled H Bid)
        -> (b : Bid ** (maximum (snd b1) (snd b) = (snd b1), label b = b2))
        -> MaxL b1 b2

data MaxBid : Bid -> BidLog n -> Type where
  IsMax : (bid : Bid)
       -> (bids : BidLog n)
       -> All (\b => MaxL bid b) bids
       -> MaxBid bid bids

HighestBid : BidLog _ -> Bid -> Type
HighestBid = \rec, b => (Elem (label b) rec, MaxBid b rec)

HighestBidHatch : BidLog _ -> Type
HighestBidHatch rec = Labeled H (b : Bid ** HighestBid rec b) -> Labeled L Bid

HatchPair : Nat -> Type
HatchPair n = (rec : BidLog n ** Labeled H (b : Bid ** HighestBid rec b) -> Labeled L Bid)

aHatchPair : HatchPair 2
aHatchPair =
  let rec : BidLog 2 = [(label ("Alice", 1337)), (label ("Bob", 1336))]
  in predicateHatch rec HighestBid

printBid : Labeled L Bid -> DIO L ()
printBid (MkLabeled (n, b)) = lift $ putStrLn n

--------------------------------------------------------------------------------
-- UTCB
--------------------------------------------------------------------------------
-- Lemmas
--------------------------------------------------------------------------------
maximum_trans : maximum a c = a -> maximum b a = b -> maximum b c = b
maximum_trans {a} {b} {c} prf prf1 =
  rewrite sym prf1 in
  rewrite sym $ maximumAssociative b a c in
  rewrite sym prf in Refl

maximum_inj : (maximum (S a) (S b) = (S a) -> Void) -> (maximum a b = a -> Void)
maximum_inj {a} {b} f prf =
  void $ f (rewrite prf in Refl)

maximum_l_void : (maximum a b = a -> Void) -> maximum a b = b
maximum_l_void {a = Z} {b = b} f = Refl
maximum_l_void {a = (S k)} {b = Z} f = void $ f Refl
maximum_l_void {a = (S k)} {b = (S j)} f =
  let ihPrf = maximum_inj {a = k} {b = j} f
      ih : (maximum k j = j) = maximum_l_void ihPrf
  in rewrite ih in Refl

all_max_ext : {b1, b2 : Bid}
      -> All (\b => MaxL b2 b) bs
      -> maximum (snd b1) (snd b2) = (snd b1)
      -> All (\b => MaxL b1 b) bs
all_max_ext [] prf = []
all_max_ext {bs = x :: _} {b1} (y :: z) prf =
  let (IsMaxL _ x (c ** (d, e))) = y
  in  (IsMaxL b1 x (c ** (maximum_trans d prf, e))) :: all_max_ext z prf

maxBid_ext : {b1, b2 : Bid}
     -> maximum (snd b1) (snd b2) = (snd b1)
     -> MaxBid b2 bs
     -> MaxBid b1 ((label b1) :: bs)
maxBid_ext {b1} {b2} {bs} maxPrf maxbid =
  let (IsMax _ _ maxbidAll) = maxbid
      headPrf = IsMaxL b1 (label b1) (b1 ** (maximumIdempotent (snd b1), Refl))
      tailPrf = all_max_ext maxbidAll maxPrf
  in IsMax b1 ((label b1) :: bs) (headPrf :: tailPrf)

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

auction : HatchPair n -> DIO L (Labeled L Bid)
auction ([] ** _) = pure $ label ("no bid", 0)
auction (r :: rs ** hatch) =
     do max <- plug $ getMaxBid (r :: rs)
        let max' : Labeled L Bid = hatch max
        printBid max'
        pure max'
  where
    getMaxBid : (r : BidLog (S n))
             -> DIO H (b : Bid ** HighestBid r b)
    getMaxBid (x :: []) =
      do (x' ** prfx) <- unlabel' x
         let elemPrf : Elem (label x') [x] = rewrite prfx in Here
         let maxlemma = (x' ** (maximumIdempotent (snd x'), prfx))
         let maxPrf : MaxBid x' [x] = IsMax x' [x] ((IsMaxL x' x maxlemma) :: Nil)
         pure (x' ** (elemPrf, maxPrf))
    getMaxBid (x :: y :: zs) =
      do (x' ** prfx) <- unlabel' x
         (tail' ** (prftailElem, prftailMax)) <- getMaxBid (y :: zs)
         let (IsMax _ _ tailprfAll) = prftailMax
         case decEq (maximum (snd x') (snd tail')) (snd x') of
           Yes prf => pure (x' ** (rewrite prfx in Here, rewrite sym prfx in maxBid_ext prf prftailMax))
           No cont => pure (tail' ** (There prftailElem, IsMax tail' (x :: y :: zs)
             ((IsMaxL tail' x (x' ** (
             rewrite maximumCommutative (snd tail') (snd x') in maximum_l_void {b=(snd tail')} cont, prfx))) :: tailprfAll)))

--------------------------------------------------------------------------------
-- TCB
--------------------------------------------------------------------------------
main : IO ()
main =
  do putStrLn "##### Welcome to the auction! #####"
     putStrLn "Announcing winner: "
     max <- run $ auction aHatchPair
     putStrLn "##### Bye bye! #####"
     pure ()


test1 : Int -> Int
test1 0x100 = 42
test1 0o100 = 43
test1 1234567890 = 44
test1 _         = 0


-- Prototype of RealizedFunction as described in
-- https://blog.singularitynet.io/ai-dsl-toward-a-general-purpose-description-language-for-ai-agents-21459f691b9e
--
-- This is similar to SimpleDataRealizedFunction but the attributes
-- are wrapped in RealizedAttributes.

module RealizedFunction

import public RealizedAttributes

public export
data RealizedFunction : (t : Type) -> (attrs : RealizedAttributes) -> Type where
  MkRealizedFunction : (f : t) -> (attrs : RealizedAttributes)
                       -> RealizedFunction t attrs

-- Perform the composition between 2 realized functions.  The
-- resulting realized function is formed as follows:
--
-- 1. Composed lifted functions
-- 2. Use add_costs_min_quality for composing attributes
public export
compose : {a : Type} -> {b : Type} -> {c : Type} ->
          (RealizedFunction (b -> c) g_attrs) ->
          (RealizedFunction (a -> b) f_attrs) ->
          (RealizedFunction (a -> c) (add_costs_min_quality f_attrs g_attrs))
compose (MkRealizedFunction f f_attrs) (MkRealizedFunction g g_attrs) =
  MkRealizedFunction (f . g) (add_costs_min_quality f_attrs g_attrs)

-- Perform function application over realized functions.  Maybe we'd
-- want to used some funded data, as defined in FndType.
public export
apply : (RealizedFunction (a -> b) attrs) -> a -> b
apply (MkRealizedFunction f attrs) = f


parameters (X : Nat)
  Foo : Type
  Foo = Nat

  record Bar where
    constructor MkBar
    Gnu : Foo

  Baz : Foo -> Nat
  Baz x = x

  Quux : Bar -> Foo
  Quux x = Gnu x


total
tailRecId : (a -> Either a b) -> a -> b
tailRecId f a with (f a)
  tailRecId f a | Left a2 = tailRecId f a2
  tailRecId f a | Right x = x