module Data.OneOf

import public Data.List.Elem
import public Data.HList

%default total

public export
data OneOf : List Type -> Type where
  Here : x -> OneOf (x :: xs)
  There : OneOf xs -> OneOf (x :: xs)

public export
make : Elem a as => a -> OneOf as
make x @{Here} = Here x
make x @{There _} = There (make x)

public export
TypeAt : (as : List Type) -> OneOf as -> Type
TypeAt (x :: _) (Here _) = x
TypeAt (_ :: xs) (There x) = TypeAt xs x

public export
Eliminators : (as : List Type) -> (r : Type) -> Type
Eliminators xs r = HList (map (\x => x -> r) xs)

public export
get : (o : OneOf as) -> TypeAt as o
get (Here x) = x
get (There x) = get x

public export
match : OneOf as -> Eliminators as r -> r
match (Here x) (f :: _) = f x
match (There x) (_ :: fs) = match x fs

public export
extend : OneOf as -> OneOf (as ++ bs)
extend (Here x) = Here x
extend (There x) = There (extend x)


import Data.List
import Data.List1
import Data.Vect
import Data.Vect.Elem
import Data.Vect.Extra
import Data.String.Parser

import System.File

Pos : Type
Pos = Vect 3 Integer

addVec : Pos -> Pos -> Pos
addVec [x1,y1,z1] [x2,y2,z2] = [x1+x2,y1+y2,z1+z2]

minVec : Pos -> Pos -> Pos
minVec [x1,y1,z1] [x2,y2,z2] = [x1-x2,y1-y2,z1-z2]

dist : Pos -> Pos -> Integer
dist p1 p2 = sum $ abs <$> minVec p1 p2

rotateVecZ : Vect 3 Integer -> List (Vect 3 Integer)
rotateVecZ [x,y,z] = [[x,y,z],[-y,x,z],[-x,-y,z],[y,-x,z]]

rotateVec3 : Vect 3 Integer -> List (Vect 3 Integer)
rotateVec3 [x,y,z] = join $ rotateVecZ <$> [[x,y,z],[-x,y,-z],[z,y,-x],[-z,y,x],[x,z,-y],[x,-z,y]]

Scanner : Type
Scanner = List Pos

Input : Type
Input = List1 Scanner

posParser : Parser Pos
posParser = do x <- integer
               skip $ char ','
               y <- integer
               skip $ char ','
               z <- integer
               pure [x, y, z]

some1 : Parser a -> Parser (List1 a)
some1 p = do Just s <- fromList <$> some p
               | Nothing => fail "none"
             pure s

scannerParser : Parser Scanner
scannerParser = token "---" *> token "scanner" *> lexeme natural *> token "---" *> some (posParser <* spaces)

parser : Parser Input
parser = some1 (scannerParser <* spaces)

rotateScanner : Scanner -> List Scanner
rotateScanner s = transpose $ rotateVec3 <$> s

moveRel : Scanner -> Pos -> Scanner
moveRel l p = map (addVec p) l

overlaps : Scanner -> Scanner -> Pos -> Bool
overlaps abs rels offset = (count ((flip elem) rels) $ (flip minVec) offset <$> abs) >= 12

overlap : Scanner -> Scanner -> Maybe (Scanner, Pos)
overlap abs rels = map (\f => (union abs $ moveRel rels f, f)) $ find (overlaps abs rels) $ (join $ (\a => minVec a <$> rels) <$> abs)

anyOverlap : Scanner -> List Scanner -> Maybe (Scanner, Pos)
anyOverlap abs [] = Nothing
anyOverlap abs (x :: xs) = overlap abs x <|> anyOverlap abs xs

findOverlap : Scanner -> List (List Scanner) -> Maybe (Scanner, Pos, List (List Scanner))
findOverlap abs [] = Nothing
findOverlap abs (rel :: rels) = case anyOverlap abs rel of
                                     Nothing => do (abs, offset, rels) <- findOverlap abs rels
                                                   pure (abs, offset, rel :: rels)
                                     (Just (abs, offset)) => Just (abs, offset, rels)

overlapall : Scanner -> List (List Scanner) -> IO (Maybe (Scanner, List Pos))
overlapall abs [] = pure $ Just (abs, [])
overlapall abs rels = do Just (abs, offset, rels) <- pure $ findOverlap abs rels
                           | Nothing => pure Nothing
                         putStrLn $ (show $ length rels) ++ "scanners left"
                         Just (all, offsets) <- overlapall abs rels
                           | Nothing => pure Nothing
                         pure $ Just (all, offset :: offsets)

part1and2 : Input -> IO String
part1and2 (x ::: xs) = do Just (bs, offsets) <- overlapall x (rotateScanner <$> xs)
                            | Nothing => pure "no overlap"
                          putStrLn $ show $ length bs
                          pure $ show $ foldl max 0 $ join $ (\o => dist o <$> offsets) <$> offsets

main : IO ()
main = do Right input <- readFile "input.txt"
            | Left err => printLn err
          Right (a, _) <- pure $ parse parser input
            | Left err => printLn err
          part1and2 a >>= putStrLn


module Decidable.Order

import Decidable.Decidable
import Decidable.Equality
import Data.Fin
import Data.Fun
import Data.Rel

%hide Prelude.Equal

--------------------------------------------------------------------------------
-- Utility Lemmas
--------------------------------------------------------------------------------

--------------------------------------------------------------------------------
-- Preorders, Posets, total Orders, Equivalencies, Congruencies
--------------------------------------------------------------------------------

public export
interface Preorder t (po : t -> t -> Type) where
  total transitive : (a : t) -> (b : t) -> (c : t) -> po a b -> po b c -> po a c
  total reflexive : (a : t) -> po a a

public export
interface (Preorder t po) => Poset t (po : t -> t -> Type) where
  total antisymmetric : (a : t) -> (b : t) -> po a b -> po b a -> a = b

public export
interface (Poset t to) => Ordered t (to : t -> t -> Type) where
  total order : (a : t) -> (b : t) -> Either (to a b) (to b a)

public export
interface (Preorder t eq) => Equivalence t (eq : t -> t -> Type) where
  total symmetric : (a : t) -> (b : t) -> eq a b -> eq b a

public export
interface (Equivalence t eq) => Congruence t (f : t -> t) (eq : t -> t -> Type) where
  total congruent : (a : t) ->
                    (b : t) ->
                    eq a b ->
                    eq (f a) (f b)

public export
minimum : (Ordered t to) => t -> t -> t
minimum {to} x y with (order {to} x y)
  minimum {to} x y | Left _ = x
  minimum {to} x y | Right _ = y

public export
maximum : (Ordered t to) => t -> t -> t
maximum {to} x y with (order {to} x y)
  maximum {to} x y | Left _ = y
  maximum {to} x y | Right _ = x

--------------------------------------------------------------------------------
-- Syntactic equivalence (=)
--------------------------------------------------------------------------------

public export
implementation Preorder t Equal where
  transitive a b c l r = trans l r
  reflexive a = Refl

public export
implementation Equivalence t Equal where
  symmetric a b prf = sym prf

public export
implementation Congruence t f Equal where
  congruent a b eq = cong f eq


module Quantities.SIPrefixes

import Quantities.Core

%default total
%access public export

makePrefix : Integer -> Unit q -> Unit q
makePrefix i (MkUnit e us) = MkUnit (e+i) us

-- List of prefixes from
-- http://en.wikipedia.org/wiki/Metric_prefix

yotta : Unit q -> Unit q
yotta = makePrefix 24

zetta : Unit q -> Unit q
zetta = makePrefix 21

exa : Unit q -> Unit q
exa = makePrefix 18

peta : Unit q -> Unit q
peta = makePrefix 15

tera : Unit q -> Unit q
tera = makePrefix 12

giga : Unit q -> Unit q
giga = makePrefix 9
G : Unit q -> Unit q
G = giga

mega : Unit q -> Unit q
mega = makePrefix 6
M : Unit q -> Unit q
M = mega

kilo : Unit q -> Unit q
kilo = makePrefix 3
k : Unit q -> Unit q
k = kilo

hecto : Unit q -> Unit q
hecto = makePrefix 2

deca : Unit q -> Unit q
deca = makePrefix 1
da : Unit q -> Unit q
da = deca

-- ################## --

deci : Unit q -> Unit q
deci = makePrefix (-1)

centi : Unit q -> Unit q
centi = makePrefix (-2)

milli : Unit q -> Unit q
milli = makePrefix (-3)

micro : Unit q -> Unit q
micro = makePrefix (-6)

nano : Unit q -> Unit q
nano = makePrefix (-9)

pico : Unit q -> Unit q
pico = makePrefix (-12)

femto : Unit q -> Unit q
femto = makePrefix (-15)

atto : Unit q -> Unit q
atto = makePrefix (-18)

zepto : Unit q -> Unit q
zepto = makePrefix (-21)

yocto : Unit q -> Unit q
yocto = makePrefix (-24)


module TreeQ

%default total
%access public export

||| A tree structure for combining queries, perhaps slightly less expressive
||| than a free monad, but easier to prove total, etc. I say less expressive,
||| because I do not believe it is a monad, whereas my applicative instance
||| seems pretty solid. Moreover, it has a nice monoid instance, given a monoid
||| on the type it is parameterized over (but requiring no effort from the query
||| GADT). I have also provided a generalized semigroup operation based on
||| pairing items together. However, regrettable, it does not seem to be
||| foldable, since some of it's data is based on a future promise and isn't
||| available yet. This means it is not traversable. However, I think this may
||| be okay: ultimately the point of traversing is to push the query to the
||| outside until we're ready to run it, so the traverse instances of list,
||| maybe and either should serve us well enough, since we just barely make the
||| minimum requirement (applicative) to play ball with them.
data QryTree : (Type -> Type) -> Type -> Type where
  ||| Pure for monad/applicative: lift a plain value into the tree
  PureLeaf : a -> QryTree q a
  ||| Lift a query into the tree
  LiftLeaf : q i -> (i -> a) -> QryTree q a
  ||| Gives us a monoid operation
  Branch : QryTree q a -> QryTree q b -> ((a, b) -> c) -> QryTree q c

liftQ : q a -> QryTree q a
liftQ qry = LiftLeaf qry id

infixr 5 ^+^

||| Generalized semigroup operation
(^+^) : QryTree q a -> QryTree q b -> QryTree q (a, b)
q ^+^ r = Branch q r id

Semigroup a => Semigroup (QryTree q a) where
  q <+> r = Branch q r (uncurry (<+>))

Monoid a => Monoid (QryTree q a) where
  neutral = PureLeaf neutral

Functor q => Functor (QryTree q) where
  map f (PureLeaf x) = PureLeaf (f x)
  map f (LiftLeaf q handle) = LiftLeaf q (f . handle)
  map f (Branch q r handle) = Branch q r (f . handle)

-- A foldable instance does not seem possible. You could start easily enough:
-- Foldable (QryTree q) where
--   foldr func init (PureLeaf x) = func x init
-- But where would you go from there?
--   foldr func init (LiftLeaf x f) = ?foldable_moldable_2
--   foldr func init (Branch x y f) = ?foldable_moldable_3
-- The data you have promised right now is stuck in the future...

||| The s combinator, with a dash of uncurrying
s' : (a -> (b -> c)) -> (d -> b) -> (a, d) -> c
s' f g (x, y) = f x (g y)

||| I am not any good at equality proofs in Idris. However, I am not content to
||| rest uncertain about whether this applicative instance is lawful! So here
||| you go: back to geometry class: a long-hand proof, in the comments!
|||
||| identity: pure id <*> v = v
|||   PureLeaf id <*> v = v
|||   | PureLeaf id <*> PureLeaf x = v
|||     -> PureLeaf (id x) = v
|||     -> PureLeaf x = v
|||     -> v = v
|||     -> QED
|||   | PureLeaf id <*> LiftLeaf q g = v
|||     -> LiftLeaf q (id . g) = v
|||     -> LiftLeaf q g = v
|||     -> v = v
|||     -> QED
|||   | PureLeaf id <*> Branch q r g = v
|||     -> Branch q r (id . g) = v
|||     -> Branch q r g = v
|||     -> v = v
|||     -> QED
|||   -> QED
|||
||| composition: pure (.) <*> u <*> v <*> w = u <*> (v <*> w)
|||   PureLeaf (.) <*> u <*> v <*> w = u <*> (v <*> w)
|||   PureLeaf (\f g x => f (g x)) <*> u <*> v <*> w = u <*> (v <*> w)
|||   | PureLeaf (.) <*> PureLeaf u' <*> v <*> w = PureLeaf u' <*> (v <*> w)
|||     | PureLeaf (u' .) <*> PureLeaf v' <*> w = PureLeaf u' <*> (PureLeaf v' <*> w)
|||       -> PureLeaf (u' . v') <*> w = PureLeaf u' <*> (PureLeaf v' <*> w)
|||          | PureLeaf (\x => u' (v' x)) <*> PureLeaf w' = PureLeaf u' <*> (PureLeaf v' <*> PureLeaf w')
|||            -> PureLeaf (u' (v' w')) = PureLeaf u' <*> PureLeaf (v' w')
|||            -> PureLeaf (u' (v' w')) = PureLeaf (u' (v' w'))
|||            -> QED
|||          | PureLeaf (u' . v') <*> LiftLeaf q w' = PureLeaf u' <*> (PureLeaf v' <*> LiftLeaf q w')
|||            -> LiftLeaf q ((u' . v') . w') = PureLeaf u' <*> (LiftLeaf q (v' . w'))
|||            -> LiftLeaf q (u' . (v' . w')) = LiftLeaf q (u' . (v' . w'))
|||            -> QED
|||          | PureLeaf (u' . v') <*> Branch q r w' = PureLeaf u' <*> (PureLeaf v' <*> Branch q r w')
|||            -> Branch q r ((u' . v') . w') = PureLeaf u' <*> (Branch q r (v' . w'))
|||            -> Branch q r (u' . (v' . w')) = Branch q r (u' . (v' . w'))
|||            -> QED
|||       -> QED
|||     | PureLeaf (u' .) <*> LiftLeaf q v' <*> w = PureLeaf u' <*> (LiftLeaf q v' <*> w)
|||       -> LiftLeaf q ((u' .) . v') <*> w = PureLeaf u' <*> (LiftLeaf q v' <*> w)
|||       -> LiftLeaf q ((\g x => u' (g x)) . v') <*> w = PureLeaf u' <*> (LiftLeaf q v' <*> w)
|||       -> LiftLeaf q (\y => (\g x => u' (g x)) (v' y)) <*> w = PureLeaf u' <*> (LiftLeaf q v' <*> w)
|||       -> LiftLeaf q (\y x => u' (v' y x)) <*> w = PureLeaf u' <*> (LiftLeaf q v' <*> w)
|||          | LiftLeaf q (\y x => u' (v' y x)) <*> PureLeaf w' = PureLeaf u' <*> (LiftLeaf q v' <*> PureLeaf w')
|||            -> LiftLeaf q (\z => (\y x => u' (v' y x)) z w') = PureLeaf u' <*> (LiftLeaf q (\y => v' y w'))
|||            -> LiftLeaf q (\z => (\x => u' (v' z x)) w') = LiftLeaf q (\z => u' ((\y => v' y w') z))
|||            -> LiftLeaf q (\z => u' (v' z w')) = LiftLeaf q (\z => u' (v' z w'))
|||            -> QED
|||          | LiftLeaf q (\y x => u' (v' y x)) <*> LiftLeaf r w' = PureLeaf u' <*> (LiftLeaf q v' <*> LiftLeaf r w')
|||            -> Brand (LiftLeaf q id) (LiftLeaf r id) (s' (\y x => u' (v' y x)) w') = PureLeaf u' <*> (Branch (LiftLeaf q id) (LiftLeaf r id) (s' v' w'))
|||            -> Brand (LiftLeaf q id) (LiftLeaf r id)  (\(a, b) => (\y x => u' (v' y x)) a (w' b)) = Branch (LiftLeaf q id) (LiftLeaf r id)  (u' . s' v' w')
|||            -> ... (\(a, b) => (\x => u' (v' a x)) (w' b)) = ... (u' . s' v' w')
|||            -> ... (\(a, b) => u' (v' a (w' b))) = ... (u' . s' v' w')
|||            -> ... (\(a, b) => u' (s' v' w' (a, b))) = ... (u' . s' v' w')
|||            -> ... (\(a, b) => (u' . s' v' w') (a, b)) = ... (u' . s' v' w')
|||            -> ... (u' . s' v' w') = ... (u' . s' v' w')
|||            -> QED
|||          | LiftLeaf q (\y x => u' (v' y x)) <*> Branch r s w' = PureLeaf u' <*> (LiftLeaf q v' <*> Branch r s w')
|||            -> Brand (LiftLeaf q id) (Breanch r s id) (s' (\y x => u' (v' y x)) w') = PureLeaf u' <*> (Branch (LiftLeaf q id) (Breanch r s id) (s' v' w'))
|||            -> Brand (LiftLeaf q id) (Breanch r s id)  (\(a, b) => (\y x => u' (v' y x)) a (w' b)) = Branch (LiftLeaf q id) (Breanch r s id)  (u' . s' v' w')
|||            -> ... (\(a, b) => (\x => u' (v' a x)) (w' b)) = ... (u' . s' v' w')
|||            -> ... (\(a, b) => u' (v' a (w' b))) = ... (u' . s' v' w')
|||            -> ... (\(a, b) => u' (s' v' w' (a, b))) = ... (u' . s' v' w')
|||            -> ... (\(a, b) => (u' . s' v' w') (a, b)) = ... (u' . s' v' w')
|||            -> ... (u' . s' v' w') = ... (u' . s' v' w')
|||            -> QED
|||       -> QED
||| Suddenly I do the math and realized that I'm only 2/9th's done... perhaps
||| there is a better way to approach this than doing it late at night. The
||| results so far are very promising in that it seems that the same laborious
||| technique should continue to work. Perhaps this could be reduced more easily
||| by introducing some lemmas. Or by figuring out how to do it with Idris. Or
||| by researching if it has been done before. Or one could argue this way: we
||| have at this point really encountered all the scenarios. Things work right
||| if pure comes before, or after; it cancels out. LiftLeaf and Branch
||| fundamentally have the same semanticcs, and the proof above regarding the
||| semantics of the S-combinator seem conclusive for all cases involving them.
||| It seems that for a proof of this length, it is foolhardy to continue
||| without computer assistance and checking. My sense that this is not a bogus
||| implementation of applicative is quite high at this point. I leave it as an
||| exercise for the reader to complete, where by "the reader" I mean "me, I
||| hope, at some later date."
|||
||| homomorphism: pure f <*> pure x = pure (f x)
|||   PureLeaf f <*> PureLeaf x = PureLeaf (f x)
|||   -> QED
|||
||| interchange: u <*> pure y = pure ($ y) <*> u
|||   u <*> PureLeaf y = PureLeaf ($ y) <*> u
|||   | PureLeaf f <*> PureLeaf y = PureLeaf ($ y) <*> PureLeaf f
|||     -> PureLeaf (f y) = PureLeaf (f $ y)
|||     -> PureLeaf (f y) = PureLeaf (f y)
|||     -> QED
|||   | LiftLeaf q f <*> PureLeaf y = PureLeaf ($ y) <*> LiftLeaf q f
|||     -> LiftLeaf q f <*> PureLeaf y = PureLeaf ($ y) <*> LiftLeaf q f
|||     -> LiftLeaf q (\z => f z y) = LiftLeaf q ((\x => \g => g x) y . f)
|||     -> LiftLeaf q (\z => f z y) = LiftLeaf q ((\g => g y) . f)
|||     -> LiftLeaf q (\z => f z y) = LiftLeaf q (\z => (\g => g y) (f z))
|||     -> LiftLeaf q (\z => f z y) = LiftLeaf q (\z => f z y)
|||     -> QED
|||   | Branch q r f <*> PureLeaf y = PureLeaf ($ y) <*> Branch q r f
|||     -> Branch q r f <*> PureLeaf y = PureLeaf ($ y) <*> Branch q r f
|||     -> Branch q r (\z => f z y) = Branch q r ((\x => \g => g x) y . f)
|||     -> Branch q r (\z => f z y) = Branch q r ((\g => g y) . f)
|||     -> Branch q r (\z => f z y) = Branch q r (\z => (\g => g y) (f z))
|||     -> Branch q r (\z => f z y) = Branch q r (\z => f z y)
|||     -> QED
|||   -> QED
|||
||| These are the four properties I found needful to prove based on my
||| understanding of Haskell's Control.Applicative documentation.
Functor q => Applicative (QryTree q) where
  pure = PureLeaf
  (PureLeaf f) <*> (PureLeaf x) =
    PureLeaf (f x)
  (PureLeaf f) <*> (LiftLeaf q g) =
    LiftLeaf q (f . g)
  (PureLeaf f) <*> (Branch q r g) =
    Branch q r (f . g)
  (LiftLeaf q f) <*> (PureLeaf x) =
    LiftLeaf q (\y => f y x)
  (LiftLeaf q f) <*> (LiftLeaf r g) =
    Branch (LiftLeaf q id) (LiftLeaf r id) $ s' f g
  (LiftLeaf q f) <*> (Branch r s g) =
    Branch (LiftLeaf q id) (Branch r s id) $ s' f g
  (Branch q r f) <*> (PureLeaf x) =
    Branch q r (\y => f y x)
  (Branch q r f) <*> (LiftLeaf s g) =
    Branch (Branch q r id) (LiftLeaf s id) $ s' f g
  (Branch q r f) <*> (Branch s t g) =
    Branch (Branch q r id) (Branch s t id) $ s' f g

-- How would you implement a monad?
-- Functor q => Monad (QryTree q) where
-- The first case would be easy:
--   (PureLeaf x) >>= f = f x
-- However, wouldn't you get stuck on these?
--   (LiftLeaf x g) >>= f = ?monads_yikes_2
--   (Branch x y g) >>= f = ?monads_yikes_3
-- It seems that we have insufficient power to smash down the results, since we
-- cannot actually produce the tree from f in these cases, without introducing
-- another lambda abstraction: but if we do that, we have to wrap it in a tree:
-- but then, inside the lambda abstraction, we cannot destroy the tree that we
-- got out of the f; I take this as a proof that there is no monad instance.

||| Example specific query GADT
data FSQry : Type -> Type where
  LsFiles : String -> FSQry (List String)
  ReadText : String -> FSQry String
  DirExists : String -> FSQry Bool

||| Example accompanying commands, to in conjunction with the FSQry, form a sort
||| of little filesystem DSL.
data FSCmd
  = WriteLines String (List String)
  | CreateDir String
  | DeleteFile String
  | DeleteDir String

lsFiles : String -> QryTree FSQry (List String)
lsFiles = liftQ . LsFiles

readText : String -> QryTree FSQry String
readText  = liftQ . ReadText

consolidate' : String -> String -> List String -> List String -> List FSCmd
consolidate' from to files texts =
  map DeleteFile files
  ++ [ DeleteDir from
     , CreateDir to
     , WriteLines (to ++ "/" ++ "consolidated.txt") texts
     ]

-- Very sadly, it here appears that our type has insufficient power.
--consolidate : String -> String -> QryTree FSQry (List FSCmd)
consolidate from to = ?tragedy
--  (\files => consolidate' from to files <$> traverse readText files)
--  <*> lsFiles from


module Main

import Parity
import System

data Bit : Nat -> Type where
     b0 : Bit 0
     b1 : Bit 1

instance Show (Bit n) where
     show b0 = "0"
     show b1 = "1"

infixl 5 #

data Binary : (width : Nat) -> (value : Nat) -> Type where
     zero : Binary Z Z
     (#)  : %erase v
            Binary w v -> (p : Bit bit) -> Binary (S w) (bit + 2 * v)

instance Show (Binary w k) where
     show zero = ""
     show (bin # bit) = show bin ++ show bit

pad : Binary w n -> Binary (S w) n
pad zero = zero # b0
pad (num # x) = pad num # x

natToBin : (width : Nat) -> (n : Nat) ->
           Maybe (Binary width n)
natToBin Z (S k) = Nothing
natToBin Z Z = Just zero
natToBin (S w) Z = do x <- natToBin w Z
                      Just (pad x)
natToBin (S w) (S k) with (parity k)
  natToBin (S w) (S (plus j j)) | even = do jbin <- natToBin w j
                                            let value = jbin # b1
                                            ?ntbEven
  natToBin (S w) (S (S (plus j j))) | odd = do jbin <- natToBin w (S j)
                                               let value = jbin # b0
                                               ?ntbOdd

pattern syntax bitpair [x] [y] = (_ ** (_ ** (x, y, _)))
term    syntax bitpair [x] [y] = (_ ** (_ ** (x, y, refl)))

addBit : Bit x -> Bit y -> Bit c ->
          (bx ** (by ** (Bit bx, Bit by, c + x + y = by + 2 * bx)))
addBit b0 b0 b0 = bitpair b0 b0
addBit b0 b0 b1 = bitpair b0 b1
addBit b0 b1 b0 = bitpair b0 b1
addBit b0 b1 b1 = bitpair b1 b0
addBit b1 b0 b0 = bitpair b0 b1
addBit b1 b0 b1 = bitpair b1 b0
addBit b1 b1 b0 = bitpair b1 b0
addBit b1 b1 b1 = bitpair b1 b1

adc : Binary w x -> Binary w y -> Bit c -> Binary (S w) (c + x + y)
adc zero        zero        carry ?= zero # carry
adc (numx # bx) (numy # by) carry
   ?= let (bitpair carry0 lsb) = addBit bx by carry in
          adc numx numy carry0 # lsb

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

readNum : IO Nat
readNum = do putStr "Enter a number:"
             return (fromInteger (cast !getLine))

mainLoop : Int -> IO ()
mainLoop i
     = do putStrLn $ "Calc " ++ show i
          let Just bin1 = natToBin 8 !readNum
          print bin1
          let Just bin2 = natToBin 8 !readNum
          print bin2
          print (adc bin1 bin2 b0)
          mainLoop (i + 1)

main : IO ()
main = mainLoop 1

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

Main.ntbOdd = proof {
    intro w,j;
    rewrite sym (plusZeroRightNeutral j);
    rewrite plusSuccRightSucc j j;
    intros;
    refine Just;
    trivial;
}

Main.ntbEven = proof {
    compute;
    intro w,j;
    rewrite sym (plusZeroRightNeutral j);
    intros;
    refine Just;
    trivial;
}

-- There is almost certainly an easier proof. I don't care, for now :)

Main.adc_lemma_2 = proof {
    intro c,w,v,bit0,num0;
    intro b0,v1,bit1,num1,b1;
    intro bc,x,x1,bx,bx1;
    rewrite sym (plusZeroRightNeutral x);
    rewrite sym (plusZeroRightNeutral v1);
    rewrite sym (plusZeroRightNeutral (plus (plus x v) v1));
    rewrite sym (plusZeroRightNeutral v);
    intros;
    rewrite sym (plusAssociative (plus c (plus bit0 (plus v v))) bit1 (plus v1 v1));
    rewrite  (plusAssociative c (plus bit0 (plus v v)) bit1);
    rewrite  (plusAssociative bit0 (plus v v) bit1);
    rewrite plusCommutative bit1 (plus v v);
    rewrite sym (plusAssociative c bit0 (plus bit1 (plus v v)));
    rewrite sym (plusAssociative (plus c bit0) bit1 (plus v v));
    rewrite sym b;
    rewrite plusAssociative x1 (plus x x) (plus v v);
    rewrite plusAssociative x x (plus v v);
    rewrite sym (plusAssociative x v v);
    rewrite plusCommutative v (plus x v);
    rewrite sym (plusAssociative x v (plus x v));
    rewrite (plusAssociative x1 (plus (plus x v) (plus x v)) (plus v1 v1));
    rewrite sym (plusAssociative (plus (plus x v) (plus x v)) v1 v1);
    rewrite  (plusAssociative (plus x v) (plus x v) v1);
    rewrite (plusCommutative v1 (plus x v));
    rewrite sym (plusAssociative (plus x v) v1 (plus x v));
    rewrite (plusAssociative (plus (plus x v) v1) (plus x v) v1);
    trivial;
}

Main.adc_lemma_1 = proof {
    intros;
    rewrite sym (plusZeroRightNeutral c) ;
    trivial;
}


module Flexidisc.OrdList.Diff

import public Flexidisc.OrdList.Disjoint
import public Flexidisc.OrdList.Fresh
import public Flexidisc.OrdList.Label
import public Flexidisc.OrdList.Sub
import public Flexidisc.OrdList.Type

%default total
%access public export

||| compute the difference between the first and the second list.
diffKeys : DecEq k => (xs, ys : OrdList k v o) -> OrdList k v o
diffKeys [] ys = []
diffKeys ((lx, vx) :: xs) ys with (decFresh lx ys)
  | Yes prf   = (lx, vx) :: diffKeys xs ys
  | No contra = diffKeys xs ys

||| Apply a patch `xs` to an `OrdList` `ys`.
||| The label of `ys` that are in `xs` are updated,
||| and the fresh element of `xs` are added
patch : DecEq k => (xs, ys : OrdList k v o) -> OrdList k v o
patch xs ys = merge (diffKeys ys xs) xs

diffIsSub : DecEq k => {xs : OrdList k v o} -> Sub (diffKeys xs ys) xs
diffIsSub {xs = []} = Empty
diffIsSub {xs = (lx, vx) :: xs} {ys} with (decFresh lx ys)
  | Yes prf   = Keep diffIsSub
  | No contra = Skip diffIsSub

diffIsDisjoint : DecEq k => {xs : OrdList k v o} ->
                 Disjoint (diffKeys xs ys) ys
diffIsDisjoint {xs = []} = []
diffIsDisjoint {xs = (kx, vx) :: xs} {ys} with (decFresh kx ys)
  | Yes prf  = isFreshFromEvidence prf :: diffIsDisjoint
  | No contra = diffIsDisjoint


import Data.List
import Data.List1
import Data.String.Parser

import System.File

Coord : Type
Coord = (Nat, Nat)

Dots : Type
Dots = List Coord

data Fold = Up Nat | Left Nat

Show Fold where
  show (Up n) = "fold up " ++ show n
  show (Left n) = "fold left " ++ show n

Input : Type
Input = (Dots, List Fold)

pairParser : Parser Coord
pairParser = do x <- natural
                token ","
                y <- natural
                pure (x, y)

foldParser : Parser Fold
foldParser = do token "fold along"
                (token "y=" *> Up <$> natural) <|>
                (token "x=" *> Left <$> natural)

parser : Parser Input
parser = do coords <- some (pairParser <* spaces)
            spaces
            folds <- some (foldParser <* spaces)
            pure (coords, folds)

fold1 : Fold -> Coord -> Coord
fold1 (Up f)   (x, y) = if y > f
                           then (x, minus f (minus y f))
                           else (x, y)
fold1 (Left f) (x, y) = if x > f
                           then (minus f (minus x f), y)
                           else (x, y)

fold : Fold -> Dots -> Dots
fold f dots = .head <$> (group $ sort $ fold1 f <$> dots)

part1 : Input -> IO String
part1 (dots, []) = pure "No folds"
part1 (dots, (f :: _)) = pure $ show $ length $ fold f dots

printDots : Coord -> Dots -> IO ()
printDots (_, _) [] = pure ()
printDots (lx, ly) ((y, x) :: cs) =
  do if y > ly
        then putStr $ pack $ replicate (minus y ly) '\n'
        else putStr $ pack $ replicate (minus x (lx + 1)) ' '
     putChar '#'
     printDots (x, y) cs

part2 : Input -> IO String
part2 (dots, fs) = do let r = sort $ (\(x, y) => (y, x)) <$> foldl (flip fold) dots fs
                      printDots (0, 0) r
                      pure ""

main : IO ()
main = do Right input <- readFile "input.txt"
            | Left err => printLn err
          Right (a, _) <- pure $ parse parser input
            | Left err => printLn err
          part1 a >>= putStrLn
          part2 a >>= putStrLn


module Simplicity

-- Simplicity, based on https://blockstream.com/simplicity.pdf

data Ty = One | Sum Ty Ty | Prod Ty Ty

interpTy : Ty -> Type
interpTy One = Unit
interpTy (Sum x y) = Either (interpTy x) (interpTy y)
interpTy (Prod x y) = ((interpTy x), (interpTy y))

data Term : Ty -> Ty -> Type where
  Iden : Term a a
  Comp : Term a b -> Term b c -> Term a c
  Unit : Term a One
  InjL : Term a b -> Term a (Sum b c)
  InjR : Term a c -> Term a (Sum b c)
  Case : Term (Prod a c) d -> Term (Prod b c) d -> Term (Prod (Sum a b) c) d
  Pair : Term a b -> Term a c -> Term a (Prod b c)
  Take : Term a c -> Term (Prod a b) c
  Drop : Term b c -> Term (Prod a b) c

eval : Term a b -> interpTy a -> interpTy b
eval Iden = \a => a
eval (Comp x y) = \a => eval y (eval x a)
eval Unit = \_ => ()
eval (InjL x) = \a => Left (eval x a)
eval (InjR x) = \a => Right (eval x a)
eval (Case x y) = \(ab, c) => case ab of
                                Left l => eval x (l, c)
                                Right r => eval y (r, c)
eval (Pair x y) = \a => ((eval x a), (eval y a))
eval (Take x) = \(a, b) => eval x a
eval (Drop x) = \(a, b) => eval x b

Bit : Ty
Bit = Sum One One

not : Term Bit Bit
not = Comp (Pair Iden Unit) (Case (InjR Unit) (InjL Unit))

not' : interpTy Bit -> interpTy Bit
not' b = eval not b

zero : interpTy Bit
zero = Left ()

one : interpTy Bit
one = Right ()

test : interpTy Bit
test = not' zero


import Data.Vect

-- validConv : (Num t) => Vect (m + n) t -> Vect m t -> Vect (n + 1) t
-- validConv xs w = fromList [sum (window i (length w) xs) | i <- [0..length(xs)-length(w)]]

window : (i : Nat) -> (m : Nat) -> Vect (i + (m + n)) t -> Vect m t
window i m xs = take m (drop i xs)

-- xs : Vect 5 Int
-- xs = [1,2,3,4,5]

-- ys : List (Vect 3 Int)
-- ys = [window i 3 xs | i <- [1,3]]


{--
Copyright 2021 Joel Berkeley

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
--}
||| This module contains definitions of function optimizers.
module Optimize

import Tensor

||| An `Optimizer` finds the value, in a `Tensor`-valued feature space, which (approximately)
||| optimizes a scalar-valued function over that space.
|||
||| If the function is not well-defined at points in the feature space, and this is expressed by
||| wrapping function values in some context, this extra context can be captured in the value `m`.
||| For example, a function `a -> Maybe (Tensor [] Double)`, can be optimized by an
||| `Optimizer {m=Maybe} a`.
|||
||| @domain The type of the domain over which to find the optimizer.
public export 0
Optimizer : {default id 0 m : Type -> Type} -> (0 domain : Type) -> Type
Optimizer a = (a -> m $ Tensor [] Double) -> m a

||| Construct an `Optimizer` that implements grid search over a scalar feature space. Grid search
||| approximates the optimum by evaluating the objective over a finite, evenly-spaced grid.
|||
||| @density The density of the grid.
||| @lower The lower (inclusive) bound of the grid.
||| @upper The upper (exclusive) bound of the grid.
export
gridSearch : (density : Tensor [d] Int) ->
             (lower : Tensor [d] Double) ->
             (upper : Tensor [d] Double) ->
             Optimizer (Tensor [d] Double)

||| The limited-memory BFGS (L-BFGS) optimization tactic, see
|||
||| Nocedal, Jorge, Updating quasi-Newton matrices with limited storage.
||| Math. Comp. 35 (1980), no. 151, 773–782.
|||
||| available at
|||
||| https://www.ams.org/journals/mcom/1980-35-151/S0025-5718-1980-0572855-7/
|||
||| @initial_points The points from which to start optimization.
export
lbfgs : (initial_points : Tensor [n] Double) -> Optimizer (Tensor [n] Double)


module InsertionSort
import Data.Vect

import Sorted
import Card
import ElemsAreSame

restLemma : (s : GTE (cardValue y) (cardValue z)) -> (r_prf : GTE (cardValue y) (cardValue x)) -> (restIsSorted : Sorted rest) -> (restHead : HeadIsEither rest x z) -> (w : Sorted (z :: ys)) -> Sorted (y :: rest)
restLemma {y} s r_prf restIsSorted HeadIsLeft w = SortMany y restIsSorted r_prf
restLemma {y} s r_prf restIsSorted HeadIsRight w = SortMany y restIsSorted s

elemsSwap : (restElems : ElemsAreSame (x :: (z :: ys)) rest) -> ElemsAreSame (x :: (y :: (z :: ys))) (y :: rest)
elemsSwap {y} restElems = swapHeads (PrependXIsPrependX y restElems)

total insert': (x: Card) -> (ys: Vect (S n) Card) -> Sorted ys -> HeadIs ys y ->  (z:Vect (S (S n)) Card **(Sorted z, ElemsAreSame (x::ys) z, HeadIsEither z x y))
insert' x (y::[]) SortSingle MkHeadIs = case chooseGte (cardValue x) (cardValue y) of
                                                  (Left l_prf) => (x::y::[] **(SortMany x SortSingle l_prf, PrependXIsPrependX x (PrependXIsPrependX y NilIsNil), HeadIsLeft))
                                                  (Right r_prf) => (y::x::[] **(SortMany y SortSingle r_prf, PrependXYIsPrependYX x y NilIsNil, HeadIsRight))
insert' x (y::(z :: ys)) (SortMany y w s) MkHeadIs = case chooseGte (cardValue x) (cardValue y) of
                                                (Left l_prf) => (x::y::z::ys ** (SortMany x (SortMany y w s) l_prf,
                                                                                PrependXIsPrependX x (PrependXIsPrependX y (PrependXIsPrependX z (sameListsAreSame ys))),
                                                                                HeadIsLeft))
                                                (Right r_prf) => let (rest ** (restIsSorted, restElems, restHead)) = insert' x (z::ys) (tailIsSortedToo (SortMany y w s)) MkHeadIs in
                                                                     (y::rest ** (restLemma s r_prf restIsSorted restHead w,
                                                                                elemsSwap restElems,
                                                                                HeadIsRight))

insert : (x: Card) -> (xs:Vect n Card) -> Sorted xs -> (z:Vect (S n) Card ** (Sorted z, ElemsAreSame (x::xs) z))
insert x [] sort_pf = ([x] ** (SortSingle, PrependXIsPrependX x NilIsNil))
insert x (y::ys) sort_pf = let (sortedList ** (sort_prf, sort_elems_prf, head_prf)) = insert' x (y::ys) sort_pf MkHeadIs in
                             (sortedList ** (sort_prf, sort_elems_prf))

export insertSort: (x:Vect n Card) -> (y:Vect n Card ** (Sorted y, ElemsAreSame x y))
insertSort [] = ([] ** (SortEmpty, NilIsNil))
insertSort (x :: []) = ([x] ** (SortSingle,(PrependXIsPrependX x NilIsNil)))
insertSort (x :: xs) = let (rest ** (sort, elem)) = insertSort xs
                           (y ** (o_sort, o_elems)) = insert x rest sort
                           elem_prf_new = PrependXIsPrependX x elem
                           o_elems_new = SamenessIsTransitive elem_prf_new o_elems
                           in
                           (y ** (o_sort, o_elems_new))


module Data.SnocVect

import Data.Vect

%hide Prelude.Types.elem

%default total

||| A Backwards Vect
public export
data SnocVect : Nat -> Type -> Type where
  ||| Empty snoc-vect
  Lin : SnocVect 0 a

  ||| A non-empty snoc-vect, consisting of the rest of the snoc-vect and the final element.
  (:<) : (SnocVect n a) -> a -> SnocVect (S n) a

%name SnocVect sx, sy, sz

infixl 7 <><
infixr 6 <>>

||| 'fish': Action of lists on snoc-lists
public export
(<><) : SnocVect n a -> Vect m a -> SnocVect (n + m) a
sx <>< [] = rewrite plusZeroRightNeutral n in sx
sx <>< ((::) x xs {len}) =
  rewrite sym $ plusSuccRightSucc n len in
          sx :< x <>< xs

||| 'chips': Action of snoc-lists on lists
public export
(<>>) : SnocVect j a -> Vect k a -> Vect (j + k) a
Lin       <>> xs = xs
((:<) sx x {n}) <>> xs =
  rewrite plusSuccRightSucc n k in
          sx <>> x :: xs

export
Cast (SnocVect n a) (Vect n a) where
  cast sx = rewrite sym $ plusZeroRightNeutral n in
                    sx <>> []

export
Cast (Vect n a) (SnocVect n a) where
  cast xs = Lin <>< xs

||| Transform to a vect but keeping the contents in the spine order (term depth).
public export
asVect : SnocVect n type -> Vect n type
asVect = (reverse . cast)

public export
Eq a => Eq (SnocVect n a) where
  (==) Lin Lin = True
  (==) (sx :< x) (sy :< y) = x == y && sx == sy
  (==) _ _ = False

public export
Ord a => Ord (SnocVect n a) where
  compare Lin Lin = EQ
  compare (sx :< x) (sy :< y)
    = case compare sx sy of
        EQ => compare x y
        c  => c

||| True iff input is Lin
public export
isLin : SnocVect n a -> Bool
isLin Lin = True
isLin (sx :< x) = False

||| True iff input is (:<)
public export
isSnoc : SnocVect n a -> Bool
isSnoc Lin     = False
isSnoc (sx :< x) = True

public export
(++) : (sx : SnocVect j a) ->  (sy : SnocVect k a) -> SnocVect (j + k) a
(++) sx Lin = rewrite plusZeroRightNeutral j in sx
(++) sx ((:<) sy y {n}) =
  rewrite sym $ plusSuccRightSucc j n in
          (sx ++ sy) :< y

public export
length : SnocVect n a -> Nat
length Lin = Z
length (sx :< x) = S $ length sx

export
lengthCorrect : (sx : SnocVect n a) -> length sx = n
lengthCorrect [<]       = Refl
lengthCorrect (sx :< x) = cong S (lengthCorrect sx)

public export
replicate : (k : Nat) -> a -> SnocVect k a
replicate 0 x = [<]
replicate (S k) x = replicate k x :< x

||| The "head" of the snoc-vect
public export
deah : SnocVect (S n) a -> a
deah (sx :< x) = x

||| The "tail" of the snoc-vect
public export
liat : SnocVect (S n) a -> SnocVect n a
liat (sx :< x) = sx

export
Show a => Show (SnocVect n a) where
  show sx = concat ("[< " :: intersperse ", " (show' [] sx) ++ ["]"])
    where
      show' : Vect j String -> SnocVect k a -> Vect (j + k) String
      show' acc Lin       = rewrite plusZeroRightNeutral j in acc
      show' acc ((:<) xs x {n}) =
        rewrite sym $ plusSuccRightSucc j n in
                show' (show x :: acc) xs

public export
Functor (SnocVect n) where
  map f Lin = Lin
  map f (sx :< x) = (map f sx) :< (f x)

public export
Zippable (SnocVect k) where
  zipWith _ [<] [<] = [<]
  zipWith f (sx :< x) (sy :< y) = zipWith f sx sy :< f x y

  zipWith3 _ [<] [<] [<] = [<]
  zipWith3 f (sx :< x) (sy :< y) (sz :< z) = zipWith3 f sx sy sz :< f x y z

  unzipWith f [<] = ([<], [<])
  unzipWith f (sx :< x) = let (b, c) = f x
                              (sb, sc) = unzipWith f sx in
                              (sb :< b, sc :< c)

  unzipWith3 f [<] = ([<], [<], [<])
  unzipWith3 f (sx :< x) = let (b, c, d) = f x
                               (sb, sc, sd) = unzipWith3 f sx in
                               (sb :< b, sc :< c, sd :< d)

public export
Semigroup a => Semigroup (SnocVect n a) where
  (<+>) = zipWith (<+>)

public export
{k : Nat} -> Monoid a => Monoid (SnocVect k a) where
  neutral = replicate k neutral

public export
Foldable (SnocVect n) where
  foldr f z = foldr f z . (<>> [])

  foldl f z xs = h xs where
    h : SnocVect k elem -> acc
    h Lin = z
    h (xs :< x) = f (h xs) x

  null Lin      = True
  null (_ :< _) = False

  toList = toList . (<>> [])

  foldMap f = foldl (\xs, x => xs <+> f x) neutral

public export
{k : Nat} -> Applicative (SnocVect k) where
  pure = replicate _
  fs <*> sx = zipWith apply fs sx

||| Get diagonal elements
public export
diag : SnocVect len (SnocVect len elem) -> SnocVect len elem
diag [<]             = [<]
diag (ssx :< (sx :< x)) = diag (map liat ssx) :< x

||| This monad is different from the List monad, (>>=)
||| uses the diagonal.
public export
{k : Nat} -> Monad (SnocVect k) where
  sx >>= f = diag (map f sx)

public export
Traversable (SnocVect k) where
  traverse _ Lin = pure Lin
  traverse f (xs :< x) = [| traverse f xs :< f x |]

||| Check if something is a member of a snoc-vect using the default Boolean equality.
public export
elem : Eq a => a -> SnocVect k a -> Bool
elem x Lin = False
elem x (sx :< y) = x == y || elem x sx

||| Find the first element of the snoc-vect that satisfies the predicate.
public export
find : (a -> Bool) -> SnocVect k a -> Maybe a
find p Lin = Nothing
find p (xs :< x) = if p x then Just x else find p xs

||| Satisfiable if `k` is a valid index into `xs`.
|||
||| @ k  the potential index
||| @ xs the snoc-list into which k may be an index
public export
data InBounds : (k : Nat) -> (xs : SnocVect j a) -> Type where
    ||| Z is a valid index into any cons cell
    InFirst : InBounds Z (xs :< x)
    ||| Valid indices can be extended
    InLater : InBounds k xs -> InBounds (S k) (xs :< x)

||| Find the index and proof of InBounds of the first element (if exists) of a
||| snoc-list that satisfies the given test, else `Nothing`.
public export
findIndex : (a -> Bool) -> (sx : SnocVect k a) -> Maybe $ Fin (length sx)
findIndex _ Lin = Nothing
findIndex p (xs :< x) = if p x
  then Just FZ
  else FS <$> findIndex p xs


module Hoare2

import Assn
import Expr
import Hoare
import Imp
import Logic
import Maps

%access public export

%default total

reduce_to_zero : Com
reduce_to_zero = WHILE (not (X == 0)) $
                   X ::= X - 1

reduce_to_zero_correct : HoareTriple (const ())
                                     Hoare2.reduce_to_zero
                                     (\st => st X = 0)
reduce_to_zero_correct =
  let htc = hoare_consequence_pre
              (\st => ((), BAssn (not (X == 0)) st))
              (AssignSub X (X - 1) (const ()))
              (const ())
              (hoare_assign (const ()))
              (\_, _ => ())
      htw = hoare_while (const ()) htc
  in hoare_consequence_post
       (const ())
       (\st => st X = 0)
       (\st => ((), Not (BAssn (not (X == 0)) st)))
       htw
       (\st, (_, contra) =>
           fst (nat_beq_iff (st X) 0)
               (trans (sym (notInvolutive (st X == 0)))
                      (cong {f=not} (fst not_true_iff_false contra))))

slow_assignment : Com
slow_assignment = do
  {-
    {{ X = m }}
    ->> {{ (X = m, Y = n) }}
  -}
  Y ::= 0
  {-
    {{ (X = m, Y = 0) }}
    ->> {{ X + Y = m }}
  -}
  WHILE (not (X == 0)) $ do
    {-
      {{ (X + Y = m, not (X == 0)) }}
      ->> {{ X - 1 + Y + 1 = m }}
    -}
    X ::= X - 1
    -- {{ X + Y + 1 = m }}
    Y ::= Y + 1
    -- {{ X + Y = m }}
  {-
    {{ (X + Y = m, Not (not (X == 0))) }}
    ->> {{ Y = m }}
  -}

slow_assignment_correct : HoareTriple (\st => st X = m)
                                      Hoare2.slow_assignment
                                      (\st => st Y = m)
slow_assignment_correct {m} =
  let hty = hoare_consequence_pre
              (\st => st X = m)
              (AssignSub Y 0 (\st => (st X = m, st Y = 0)))
              (\st => (st X = m, st Y = 0))
              (hoare_assign (\st => (st X = m, st Y = 0)))
              (\st, p_st => (p_st, Refl))
      htx = hoare_consequence_pre
              (\st => (st X + st Y = m, BAssn (not (X == 0)) st))
              (\st => minus (st X) 1 + (st Y + 1) = m)
              (\st => st X + (st Y + 1) = m)
              (hoare_assign (\st => st X + (st Y + 1) = m))
              (\st, (prf, x_prf) =>
                  let lte_prf =
                        notZeroImpliesGTZero
                          (fst (nat_nbeq_iff (st X) 0)
                               (trans (sym (notInvolutive (st X == 0)))
                                      (cong {f=not} x_prf)))
                  in rewrite sym prf
                  in lte_minus_plus_sum lte_prf)
      hty' = hoare_assign (\st => st X + st Y = m)
      ht_body = hoare_seq (\st => (st X + st Y = m, BAssn (not (X == 0)) st))
                          (\st => st X + (st Y + 1) = m)
                          (\st => st X + st Y = m)
                          hty'
                          htx
      htw = hoare_consequence_pre
              (\st => (st X = m, st Y = 0))
              (\st => st X + st Y = m)
              (\st => (st X + st Y = m, Not (BAssn (not (X == 0)) st)))
              (hoare_while (\st => st X + st Y = m) ht_body)
              (\_, (x_prf, y_prf) => trans (plusCong x_prf y_prf)
                                           (plusZeroRightNeutral m))
      ht_program = hoare_seq (\st => st X = m)
                             (\st => (st X = m, st Y = 0))
                             (\st => ( st X + st Y = m
                                     , Not (BAssn (not (X == 0)) st) ))
                             htw
                             hty
  in hoare_consequence_post
       (\st => st X = m)
       (\st => st Y = m)
       (\st => (st X + st Y = m, Not (BAssn (not (X == 0)) st)))
       ht_program
       (\st, (prf, contra) =>
           let st_X_eq_0 =
                 fst (nat_beq_iff (st X) 0)
                     (trans (sym (notInvolutive (st X == 0)))
                            (cong {f=not} (fst not_true_iff_false contra)))
           in replace {P=\x => x + st Y = m} st_X_eq_0 prf)

add_slowly : Com
add_slowly =
  {-
    {{ (X = m, Z = n) }}
    ->> {{ X + Z = m + n }}
  -}
  WHILE (not (X == 0)) $ do
    {-
      {{ (X + Z = m + n, BAssn (not (X == 0)) st) }}
      ->> {{ X - 1 + Z + 1 = m + n }}
    -}
    Z ::= Z + 1
    -- {{ X - 1 + Z = m + n }}
    X ::= X - 1
    -- {{ X + Z = m + n }}
  {-
    {{ (X + Z = m + n, Not (BAssn (not (X == 0)) st)) }}
    ->> {{ Z = m + n }}
  -}

parity : Nat -> Nat
parity Z = 0
parity (S Z) = 1
parity (S (S k)) = parity k

parity_ge_2 : (n : Nat) -> LTE 2 n -> parity (minus n 2) = parity n
parity_ge_2 Z lte_prf = absurd $ succNotLTEzero lte_prf
parity_ge_2 (S Z) lte_prf = absurd $ succNotLTEzero (fromLteSucc lte_prf)
parity_ge_2 (S (S k)) lte_prf = rewrite minusZeroRight k
                                in Refl

parity_lt_2 : (n : Nat) -> Not (LTE 2 n) -> parity n = n
parity_lt_2 Z _ = Refl
parity_lt_2 (S Z) _ = Refl
parity_lt_2 (S (S k)) contra =
  let lte_prf = notLTImpliesGTE contra
  in absurd $ succNotLTEzero (fromLteSucc lte_prf)

parity_correct : HoareTriple (\st => st X = m)
                             (WHILE (2 <= X) $ do
                                X ::= X - 2)
                             (\st => st X = parity m)
parity_correct {m} =
  let htx = hoare_consequence_pre
              (\st => (parity (st X) = parity m, BAssn (2 <= X) st))
              (AssignSub X (X - 2) (\st => parity (st X) = parity m))
              (\st => parity (st X) = parity m)
              (hoare_assign (\st => parity (st X) = parity m))
              (\st, (prf, cond_prf) =>
                  rewrite parity_ge_2 (st X)
                                      (fst (lte_beq_iff 2 (st X)) cond_prf)
                  in prf)
      htw = hoare_while (\st => parity (st X) = parity m) htx
  in hoare_consequence
       (\st => st X = m)
       (\st => parity (st X) = parity m)
       (\st => st X = parity m)
       (\st => (parity (st X) = parity m, Not (BAssn (2 <= X) st)))
       htw
       (\st, p_st => cong p_st)
       (\st, (prf, nbeq_prf) =>
           let lte_prf = fst (lte_nbeq_iff 2 (st X))
                             (fst not_true_iff_false nbeq_prf)
               contra = fromNotLteSucc (lteImpliesNotGT lte_prf)
           in rewrite sym prf
           in sym (parity_lt_2 (st X) contra))

factorial : Com
factorial = do
  {-
    {{ X = m }}
    ->> {{ 1 * X! = m! }}
  -}
  Y ::= 1
  -- {{ Y * X! = m! }}
  WHILE (not (X == 0)) $ do
    {-
      {{ (Y * X! = m!, BAssn (not (X == 0)) st) }}
      ->> {{ Y * X * (X - 1)! = m! }}
    -}
    Y ::= Y * X
    -- {{ Y * (X - 1)! = m! }}
    X ::= X - 1
    -- {{ Y * X! = m! }}
  {-
    {{ (Y * X! = m!, Not (BAssn (not (X == 0)) st)) }}
    ->> {{ Y = m! }}
  -}

lemma1 : (x, y : Nat) -> Either (x = 0) (y = 0) -> minimum x y = 0
lemma1 _ _ (Left x_prf) = rewrite x_prf in Refl
lemma1 Z _ (Right _) = Refl
lemma1 (S _) _ (Right y_prf) = rewrite y_prf in Refl

lemma2 : (x, y : Nat) ->
         minimum (x `minus` 1) (y `minus` 1) = minimum x y `minus` 1
lemma2 Z _ = Refl
lemma2 (S k) Z = minimumZeroZeroLeft (minus k 0)
lemma2 (S k) (S j) = rewrite minusZeroRight k
                     in rewrite minusZeroRight j
                     in rewrite minusZeroRight (minimum k j)
                     in Refl

min : (a, b : Nat) -> Com
min a b = do
  {-
    {{ () }}
    ->> {{ 0 = minimum a b - minimum a b }}
  -}
  X ::= ANum a
  -- {{ 0 = minimum a b - minimum X b }}
  Y ::= ANum b
  -- {{ 0 = minimum a b - minimum X Y }}
  Z ::= 0
  -- {{ Z = minimum a b - minimum X Y }}
  WHILE (not (X == 0) && not (Y == 0)) $ do
    {-
      {{ (Z = minimum a b - minimum X Y, BAssn (not (X == 0) && not (Y == 0)) st) }}
      ->> {{ Z + 1 = minimum a b - minimum (X - 1) (Y - 1) }}
    -}
    X ::= X - 1
    -- {{ Z + 1 = minimum a b - minimum X (Y - 1) }}
    Y ::= Y - 1
    -- {{ Z + 1 = minimum a b - minimum X Y }}
    Z ::= Z + 1
    -- {{ Z = minimum a b - minimum X Y }}
  {-
    {{ (Z = minimum a b - minimum X Y, Not (BAssn (not (X == 0) && not (Y == 0)) st)) }}
    ->> {{ Z ::= minimum a b }}
  -}

two_loops : (a, b, c : Nat) -> Com
two_loops a b c = do
  {-
    {{ () }}
    ->> {{ c = 0 + 0 + c }}
  -}
  X ::= 0
  -- {{ c = X + 0 + c }}
  Y ::= 0
  -- {{ c = X + Y + c }}
  Z ::= ANum c
  -- {{ Z = X + Y + c }}
  WHILE (not (X == ANum a)) $ do
    {-
      {{ (Z = X + Y + c, BAssn (not (X == a)) st) }}
      ->> {{Z + 1 = X + 1 + Y + c }}
    -}
    X ::= X + 1
    -- {{ Z + 1 = X + Y + c }}
    Z ::= Z + 1
    -- {{ Z = X + Y + c }}
  {-
    {{ (Z = X + Y + c, Not (BAssn (not (X == a)) st)) }}
    ->> {{ Z = a + Y + c }}
  -}
  WHILE (not (Y == ANum b)) $ do
    {-
      {{ (Z = a + Y + c, BAssn (not (Y == b)) st) }}
      ->> {{ Z + 1 = a + Y + 1 + c }}
    -}
    Y ::= Y + 1
    -- {{ Z + 1 = a + Y + c }}
    Z ::= Z + 1
    -- {{ Z = a + Y + c }}
  {-
    {{ (Z = a + Y + c, Not (BAssn (not (Y == b)) st)) }}
    ->> {{ Z = a + b + c }}
  -}

dpow2_down : (m : Nat) -> Com
dpow2_down m = do
  {-
    {{ () }}
    ->> {{ (1 = 2^(0+1) - 1, 1 = 2^0) }}
  -}
  X ::= 0
  -- {{ (1 = 2^(X+1) - 1, 1 = 2^X) }}
  Y ::= 1
  -- {{ (Y = 2^(X+1) - 1, 1 = 2^X) }}
  Z ::= 1
  -- {{ (Y = 2^(X+1) - 1, Z = 2^X) }}
  WHILE (not (X == ANum m)) $ do
    {-
      {{ (Y = 2^(X+1) - 1, Z = 2^X, BAssn (not (X == m)) st) }}
      ->> {{ (Y + 2*Z = 2^(X+1+1) - 1, 2*Z = 2^(X+1)) }}
    -}
    Z ::= 2 * Z
    -- {{ (Y + Z = 2^(X+1+1) - 1, Z = 2^(X+1)) }}
    Y ::= Y + Z
    -- {{ (Y = 2^(X+1+1) - 1, Z = 2^(X+1)) }}
    X ::= X + 1
    -- {{ (Y = 2^(X+1) - 1, Z = 2^X) }}
  {-
    {{ (Y = 2^(X+1) - 1, Z = 2^X, Not (BAssn (not (X == m)) st)) }}
    ->> {{ Y = 2^(m+1) - 1 }}
  -}

IsWP : (p : Assertion) -> (c : Com) -> (q : Assertion) -> Type
IsWP p c q = ( HoareTriple p c q
             , (p' : Assertion) -> HoareTriple p' c q -> p' ->> p )

{-
  {{ X = 5 }} SKIP {{ X = 5 }}

  {{ Y + Z = 5 }} X ::= Y + Z {{ X = 5 }}

  {{ True }} X ::= Y {{ X = Y }}

  {{ Either (X = 0, Z = 4) (Not (X = 0), W = 3) }}
  IFB X == 0 THEN Y ::= Z + 1 ELSE Y ::= W + 2 FI
  {{ Y = 5 }}

  {{ Void }} X ::= 5 {{ X = 0 }}

  {{ () }}
  WHILE BTrue $ do X ::= 0
  {{ X = 0 }}
-}

is_wp_example : IsWP (\st => LTE (st Y) 4)
                     (X ::= Y + 1)
                     (\st => LTE (st X) 5)
is_wp_example = (ht, imp)
where ht : HoareTriple (\st => LTE (st Y) 4) (X ::= Y + 1) (\st => LTE (st X) 5)
      ht = hoare_consequence_pre (\st => LTE (st Y) 4)
                                 (\st => LTE (st Y + 1) 5)
                                 (\st => LTE (st X) 5)
                                 (hoare_assign (\st => LTE (st X) 5))
                                 (\st, p_st => rewrite plusCommutative (st Y) 1
                                               in LTESucc p_st)
      imp : (p' : Assertion) ->
            HoareTriple p' (X ::= Y + 1) (\st => LTE (st X) 5) ->
            p' ->> (\st => LTE (st Y) 4)
      imp p' ht' st p'_st =
        fromLteSucc (replace {P=\x => LTE x 5}
                             (plusCommutative (st Y) 1)
                             (ht' st _ (E_Ass Refl) p'_st))

hoare_assign_weakest : IsWP (AssignSub x a q) (x ::= a) q
hoare_assign_weakest {x} {a} {q} = (hoare_assign q, imp)
where imp : (p' : Assertion) -> HoareTriple p' (x ::= a) q ->
            p' ->> AssignSub x a q
      imp p' ht st p'_st = ht st _ (E_Ass Refl) p'_st