module Control.Monad.Identity

public export
record Identity (a : Type) where
  constructor Id
  runIdentity : a

public export
Functor Identity where
    map fn (Id a) = Id (fn a)

public export
Applicative Identity where
    pure x = Id x
    (Id f) <*> (Id g) = Id (f g)

public export
Monad Identity where
    (Id x) >>= k = k x

public export
Show a => Show (Identity a) where
  showPrec d (Id x) = showCon d "Id" $ showArg x

public export
Eq a => Eq (Identity a) where
  (Id x) == (Id y) = x == y

public export
Ord a => Ord (Identity a) where
  compare (Id x) (Id y) = compare x y

-- public export
-- Enum a => Enum (Identity a) where
--   toNat (Id x) = toNat x
--   fromNat n = Id $ fromNat n
--   pred (Id n) = Id $ pred n

public export
(Semigroup a) => Semigroup (Identity a) where
  (<+>) x y = Id (runIdentity x <+> runIdentity y)

public export
(Monoid a) => Monoid (Identity a) where
  neutral = Id (neutral)


||| Spec: https://webassembly.github.io/spec/core/syntax/modules.html#start-function
module WebAssembly.Structure.Modules.StartFunction

import WebAssembly.Structure.Modules.Indices

import Decidable.Equality

-- Definition

public export
record Start where
  constructor MkStart
  func : FuncIdx

-- Equality

total public export
lemma_start__func_injective : ((f1 = f2) -> Void) -> (MkStart f1 = MkStart f2) -> Void
lemma_start__func_injective f1_not_f2 Refl = f1_not_f2 Refl

-- Decidable Equality

public export
implementation DecEq Start where
  decEq (MkStart f1) (MkStart f2) = case decEq f1 f2 of
    No f1_not_f2 => No $ lemma_start__func_injective f1_not_f2
    Yes Refl     => Yes Refl


module Test.HList

import Data.Vect
import Data.HList

%access public export
%default total

assertEq : Eq a => String -> (given : a) -> (expected : a) -> IO ()
assertEq desc g e = if g == e
    then putStr $ ""
    else putStrLn $ "Test Failed " ++ desc

sample3 : HList 3 [Nat, Bool, String]
sample3 = [S Z, True, "Yeah"]

sample3a : HList 3 [Bool, String, Integer]
sample3a = [True, "Yeah", 10]

sample4 : HList 4 [Bool, String, Integer, Nat]
sample4 = [False, "Text", 10, 4]

sample4a : HList 4 [Bool, String, Integer, Nat]
sample4a = [False, "Text", 11, 4]

testHLength :  IO ()
testHLength = do
  assertEq "Hlength" (hlength sample3) 3
  assertEq "Hlength" (hlength sample4) 4

testGet :  IO ()
testGet =
  do
    assertEq "TestGet" (S Z) (get 0 sample3)
    assertEq "TestGet" True (get 1 sample3)
    assertEq "TestGet" "Yeah" (get 2 sample3)

testSet : IO ()
testSet = do
  assertEq "TestSet" [Z, True, "Yeah"] $ set 0 sample3 Z
  assertEq "TestSet" [S Z, False, "Yeah"] $ set 1 sample3 False

testSetWith : IO ()
testSetWith = do
  assertEq "TestSetWith" [S (S Z), True, "Yeah"] $ setWith 0 sample3 (\x => (S x) )
  assertEq "TestSetWith" [S Z, False, "Yeah"] $ setWith 1 sample3 (\x => not x)

testHead : IO ()
testHead = assertEq "TestHead" (S Z) $ head sample3

testLast : IO ()
testLast = assertEq "TestLast" "Yeah" $ last sample3

testZip : IO ()
testZip =
  assertEq "TestZip" [(S Z, True), (True, "Yeah"), ("Yeah", 10)] $ zip sample3 sample3a

testTake : IO ()
testTake =
  assertEq "TestTake" [S Z, True] $ take 2 sample3

testDrop : IO ()
testDrop =
  assertEq "TestDrop" [True, "Yeah"] $ drop 1 sample3

testInit : IO ()
testInit = do
  assertEq "TestInit" [False, "Text", 10] $ init sample4
  assertEq "TestInit" [S Z, True] $ init sample3

testTail : IO ()
testTail = do
  assertEq "TestTail" [True, "Yeah"] $ tail sample3
  assertEq "TestTail" ["Text", 10, 4] $ tail sample4

testConcat : IO ()
testConcat = do
    assertEq "TestConcat" [S Z, True, "Yeah", False, "Text", 10, 4] $ sample3 ++ sample4
    assertEq "TestConcat" [False, "Text", 10, 4, S Z, True, "Yeah"] $ sample4 ++ sample3

testUpdate : IO ()
testUpdate = do
  assertEq "TestUpdate" ["YS", "Text", 10, 4] $ update 0 sample4 "YS"
  assertEq "TestUpdate" [False, "Text", "YS", 4] $ update 2 sample4 "YS"
  assertEq "TestUpdate" [False, "Text", 10, "YS"] $ update 3 sample4 "YS"

testInsertAt : IO ()
testInsertAt = do
  assertEq "TestInsertAt" [10, S Z, True, "Yeah"] $ insertAt 0 sample3 10
  assertEq "TestInsertAt" [S Z, 10, True, "Yeah"] $ insertAt 1 sample3 10
  assertEq "TestInsertAt" [S Z, True, 10, "Yeah"] $ insertAt 2 sample3 10

testDeleteAt : IO ()
testDeleteAt = do
  assertEq "DeleteAt" ["Text", 10, 4] $ deleteAt 0 sample4
  assertEq "DeleteAt" [False, 10, 4] $ deleteAt 1 sample4
  assertEq "DeleteAt" [False, "Text", 4] $ deleteAt 2 sample4
  assertEq "DeleteAt" [False, "Text", 10] $ deleteAt 3 sample4

testOrd : IO ()
testOrd = do
  assertEq "TestOrd" True $ sample4 < sample4a
  assertEq "TestOrd" False $ sample4 > sample4a

testHap : IO ()
testHap =
  let res = hap [1, "---", S Z] [f11, f12, \a => "nat" ++ (show a)]
  in assertEq "testHap" [S (S Z), 3, "nat1"] res
  where
    f11 : Integer -> Nat
    f11 a = S (cast a)
    f12 : String -> Integer
    f12 a = cast $ Prelude.Strings.length a


module Types

--data Example: Type where
--  Points: Double -> Double -> Example
public export
data Examples = Points Double Double
--data Dataset = TrainingSet [Example] | TestSet [Example]
public export
data Dataset : Type where
  TrainingSet: List Examples -> Dataset
  TestSet: List Examples -> Dataset

public export
data Coefficients = Val Double Double

example1 : Examples
example1 = Points 10.2 10.9

example2 : Examples
example2 = Points 0.0 0.0

example3 : Examples
example3 = Points 2.8 4.9

mytrainset: Dataset
mytrainset = TrainingSet [example1,example2, example3]


import Data.So

fromString : String -> Either String Nat
fromString = Left

fromInteger : (x : Integer) -> (0 _ : So (x >= 0)) => Either String Nat
fromInteger x = Right $ integerToNat x

x : List $ Either String Nat
x = ["x", 1, 2, "y"]


module Rhone.Canvas.Shape

import Control.MonadRec
import Data.Iterable
import JS
import Rhone.Canvas.Angle
import Web.Html

%default total

--------------------------------------------------------------------------------
--          Types
--------------------------------------------------------------------------------

namespace PathType
  public export
  data PathType = Fill | Stroke

public export
data Segment : Type where
  Move  :  (x,y : Double) -> Segment
  Line  :  (x,y : Double) -> Segment
  Arc   :  (x,y,radius       : Double)
        -> (start,stop       : Angle)
        -> (counterclockwise : Bool)
        -> Segment
  ArcTo :  (x1,y1,x2,y2,radius : Double) -> Segment

namespace RectType
  public export
  data RectType = Fill | Stroke | Clear

public export
data Shape : Type where
  Rect   : (x,y,w,h : Double) -> RectType -> Shape
  Path   : List Segment -> PathType -> Shape
  Shapes : List Shape -> Shape

export
circle : (x,y,radius : Double) -> PathType -> Shape
circle x y r = Path [Arc x y r (rad 0) (rad $ 2 * pi) False]

export
polyLine : List (Double,Double) -> Shape
polyLine []           = Path [] Stroke
polyLine ((x,y) :: t) = Path (Move x y :: map (uncurry Line) t) Stroke

export
Semigroup Shape where
  x         <+> Shapes [] = x
  Shapes [] <+> y         = y
  Shapes xs <+> Shapes ys = Shapes $ xs ++ ys
  x         <+> Shapes ys = Shapes $ x :: ys
  x         <+> y         = Shapes [x,y]

export
Monoid Shape where
  neutral = Shapes []

--------------------------------------------------------------------------------
--          IO
--------------------------------------------------------------------------------

applySegment : CanvasRenderingContext2D -> Segment -> JSIO ()
applySegment ctxt (Move x y) = moveTo ctxt x y
applySegment ctxt (Line x y) = lineTo ctxt x y
applySegment ctxt (Arc x y r start stop ccw) = do
  arc ctxt x y r (toRadians start) (toRadians stop) (Def ccw)
applySegment ctxt (ArcTo x1 y1 x2 y2 radius) =
  arcTo ctxt x1 y1 x2 y2 radius

mutual
  export
  applyAll : CanvasRenderingContext2D -> List Shape -> JSIO ()
  applyAll ctxt = assert_total $ forM_ (apply ctxt)

  export
  apply : CanvasRenderingContext2D -> Shape -> JSIO ()
  apply ctxt (Rect x y w h Fill)   = fillRect ctxt x y w h
  apply ctxt (Rect x y w h Stroke) = strokeRect ctxt x y w h
  apply ctxt (Rect x y w h Clear)  = clearRect ctxt x y w h
  apply ctxt (Path ss st)          = do
    beginPath ctxt
    forM_ (applySegment ctxt) ss
    case st of
      Fill   => fill ctxt Undef
      Stroke => stroke ctxt
  apply ctxt (Shapes xs)           = applyAll ctxt xs


module Units

%default total

data Unit = Degrees | Radians | Pixels | Meters
data Dim : Unit -> Type where
  Deg : Float -> Dim Degrees
  Rad : Float -> Dim Radians
  Pix : Float -> Dim Pixels
  M : Float -> Dim Meters


import Partition
import Data.String

main : IO ()
main = do
  argv <- getArgs

  n <- pure $ index' 1 argv >>= parsePositive
  ls <- pure $ naiveAllParN <$> n

  printLn ls
  printLn $ length <$> ls


module Data.Time.Clock.Internal.POSIXTime

import Data.Time.Clock.Internal.NominalDiffTime

||| 86400 nominal seconds in every day
posixDayLength: NominalDiffTime
posixDayLength = nominalDay

||| POSIX time = Nominal time since 1970-01-01 00:00 UTC

POSIXTime : Type
POSIXTime = NominalDiffTime


module Props.Char

import Data.List
import public Props.Util

%access public export

digits : List Char
digits = ['0'..'9']

lowerCase : List Char
lowerCase = ['a'..'z']

upperCase : List Char
upperCase = ['A'..'Z']

letters : List Char
letters = lowerCase ++ upperCase

whiteSpace : List Char
whiteSpace = ['\n','\t',' ']

Digit : Char -> Type
Digit c = Elem c digits

LowerCase : Char -> Type
LowerCase c = Elem c lowerCase

UpperCase : Char -> Type
UpperCase c = Elem c upperCase

Whitespace : Char -> Type
Whitespace c = Elem c whiteSpace

Letter : (c:Char) -> Type
Letter = EitherK LowerCase UpperCase

AlphaNumeric : Char -> Type
AlphaNumeric = EitherK Letter Digit


module On2

on2 : forall f, t. (t a -> t b -> c) -> (forall z. f z -> t z) -> f a -> f b -> c
on2 g h = \x, y => h x `g` h y


import ListLast

describe_help : (Show a) => (input : List a) -> (form : ListLast input) -> String
describe_help [] Empty = "Empty"
describe_help (xs ++ [x]) (NonEmpty xs x)
  = "Non-empty, initial portion = " ++ show xs

describe_list_end : Show a => List a -> String
describe_list_end xs = describe_help xs (listLast xs)

describe_list_end' : Show a => List a -> String
describe_list_end' xs with (listLast xs)
  describe_list_end' [] | Empty = "Empty"
  describe_list_end' (xs' ++ [x]) | (NonEmpty xs' x)
    = "Non-empty, initial portion = " ++ show xs'


module InvParComb

%default total

data IPC : (listtype : Type) -> (valtype : Type) -> Type where
  MkIPC : (parse : (List listtype -> Maybe (valtype, List listtype))) ->
          (compose : (valtype -> Maybe (List listtype))) ->
          IPC listtype valtype

ipc_parse : IPC a b -> List a -> Maybe (b, List a)
ipc_parse (MkIPC p c) = p

ipc_compose : IPC a b -> b -> Maybe (List a)
ipc_compose (MkIPC p c) = c

-- Functor, kind of
ipc_fmap : (fp : a -> b) -> (fc : b -> a) -> IPC c a -> IPC c b
ipc_fmap fp fc (MkIPC parse compose) = MkIPC pf cf
  where
    pf l = do
      (x, rest) <- parse l
      return (fp x, rest)
    cf x = compose $ fc x

-- Almost applicative
ipc_pure : (Eq a, Eq b) => a -> IPC a a
ipc_pure v = MkIPC pf cf
  where
    pf l = Just (v, l)
    cf x = if x == v then Just [v] else Nothing

ipc_empty : IPC a b
ipc_empty = MkIPC (\x => Nothing) (\x => Just $ List.Nil)

ipc_item : IPC a a
ipc_item = MkIPC pf cf
  where
    pf [] = Nothing
    pf (x :: xs) = Just (x, xs)
    cf x = Just [x]

ipc_fail : IPC a a
ipc_fail = MkIPC (const Nothing) (const Nothing)

-- Alternative
mplus : Maybe a -> Lazy (Maybe a) -> Maybe a
mplus Nothing m2 = m2
mplus j m2 = j

ipc_alt : IPC a b -> IPC a b -> IPC a b
ipc_alt (MkIPC p1 c1) (MkIPC p2 c2) = MkIPC pf cf
  where
    pf l = mplus (p1 l) (p2 l)
    cf x = mplus (c1 x) (c2 x)

-- Tuple
ipc_tup : IPC a b -> IPC a c -> IPC a (b, c)
ipc_tup (MkIPC p1 c1) (MkIPC p2 c2) = MkIPC pf cf
  where
   pf l = do
     (x, rest) <- p1 l
     (y, ret) <- p2 rest
     return ((x, y), ret)
   cf (x, y) = do
     l1 <- c1 x
     l2 <- c2 y
     return (l1 ++ l2)

-- Vector
ipc_nilv : IPC a (Vect 0 b)
ipc_nilv = MkIPC pf cf
  where
    pf l = Just $ ([], l)
    cf x = Just []

ipc_consv : IPC a b -> IPC a (Vect n b) -> IPC a (Vect (S n) b)
ipc_consv (MkIPC p1 c1) (MkIPC p2 c2) = MkIPC pf cf
  where
    pf l = do
      (x, rest) <- p1 l
      (xs, ret) <- p2 rest
      return (x :: xs, ret)
    cf (x :: xs) = do
      l1 <- c1 x
      l2 <- c2 xs
      return (l1 ++ l2)

ipc_rep : (n : Nat) -> IPC a b -> IPC a (Vect n b)
ipc_rep Z p = ipc_nilv
ipc_rep (S k) p = ipc_consv p (ipc_rep k p)

-- List
ipc_nil : (Eq a, Eq b) => IPC a (List b)
ipc_nil = MkIPC pf cf
  where
    pf l = Just ([], l)
    cf [] = Just []
    cf l = Nothing

ipc_cons : (Eq a, Eq b) => IPC a b -> Lazy (IPC a (List b)) -> IPC a (List b)
ipc_cons (MkIPC p1 c1) (MkIPC p2 c2) = MkIPC pf cf
  where
    pf l = do
      (x, rest) <- p1 l
      (xs, ret) <- p2 rest
      return (x :: xs, ret)
    cf [] = Nothing
    cf (x :: xs) = do
      l1 <- c1 x
      l2 <- c2 xs
      return (l1 ++ l2)


-- Like SimpleRealizedFunction but uses data instead of record

module SimpleDataRealizedFunction
%default total

public export
data SimpleDataRealizedFunction : (t : Type) -> (cost : Integer) -> (quality : Double)
                                  -> Type where
  MkSimpleDataRealizedFunction : (f : t) -> (cost : Integer) -> (quality : Double)
                                 -> SimpleDataRealizedFunction t cost quality

-- Perform the composition between 2 simple realized functions.  The
-- resulting realized function is formed as follows:
--
-- 1. Composed lifted functions
-- 2. Costs are added
-- 3. Composed quality is the min of the component qualities
public export
compose : {a : Type} -> {b : Type} -> {c : Type} ->
          (SimpleDataRealizedFunction (b -> c) g_cost g_q) ->
          (SimpleDataRealizedFunction (a -> b) f_cost f_q) ->
          (SimpleDataRealizedFunction (a -> c) (f_cost + g_cost) (min f_q g_q))
compose (MkSimpleDataRealizedFunction f f_cost f_q) (MkSimpleDataRealizedFunction g g_cost g_q) =
         MkSimpleDataRealizedFunction (f . g) (g_cost + f_cost) (min g_q f_q)

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


module Syntax

-- Gettin used to idris's syntax and type system
--
-- Those that are same as haskell are omitted, complicated syntax (like with)
-- are played in other files

-- all top-level functions/variables' types must be explicitly declared
foo : String
foo = "hello"

-- String in idris are not List Char, but rather packed Text as in haskell
bar : List Char
bar = unpack foo

-- Nat is unbound integer within [0,inf), inductively defined
data Nat' : Type where
  Z' : Nat'
  S' : Nat' -> Nat'

-- One can either use the GADT style to define a data, or simply:
data Nat'' = Z'' | S'' Nat''

replicate1 : Nat -> List Nat
replicate1 Z = []
-- replicate1 0 = Nil       -- the same
replicate1 (S k) = 1 :: replicate1 k
-- here the value 1's type is automatically set to Nat because it knows it's
-- constructing a list of Nat

-- [] is the syntatic sugar for Nil. [1,2,3] is for 1::2::3::Nil

-- idris allows overloading functions over argument types, as long as there is
-- they are defined in different namespaces,
--
-- the compiler will figure out which definition to use automatically when
-- calling with arguments with different types

-- finite set captures the idea of matching Nat that are less than or equal to a
-- given Nat.
data Fin' : Nat -> Type where
  FZ' : Fin' (S k)
  FS' : Fin' k -> Fin' (S k)

-- typeclass in haskell ~= interfaces in idris, the instance implementation
-- syntax is slightly different:

Show Nat' where
  show Z' = "Z"
  show (S' n) = "S (" ++ show n ++ ")"

-- idris doesn't have things like Constraint at the kind level. Interfaces (or
-- typeclass in haskell) are implemented as partial functions. i.e. unsatisfied
-- types are not implemented.
--
-- example with Show : Type -> Type, where Show Nat : Type is implemented and
-- Show (Nat -> Nat) : Type is not implemented (doesn't have a proof).

-- more sensible Functor/Applicative/Monad interfaces
--
-- Functor has `map' instead of `fmap' as its implementation
--
-- Applicative has `pure' and `<*>', same as Haskell
--
-- Monad has `>>=', `return' is not needed, since we already got `pure'

-- do notation works as in haskell. Monad comprehension as well. Monad
-- comprehension requires (Monad m, Alternative m) (for use of guard).
-- Alternative is the same as in haskell.

-- Multiple implementations for the same type with a interface is allowed.
--
-- e.g. Nat can be a Semigroup in two ways: additive and multiplicative
--
-- This is achieved by named impl, where a name is used when defining

[SemiNatMult] Semigroup Nat where
  (<+>) m n = m * n

[SemiNatAdd] Semigroup Nat where
  (<+>) m n = m + n

-- dependent implementation can be achieved with the 'using' syntax
[MonoidNatMult] Monoid Nat using SemiNatMult where
  neutral = 1
[MonoidNatAdd]  Monoid Nat using SemiNatAdd  where
  neutral = 0

-- !-notation makes writing monadic code easier:
--
--

m_add : Maybe Int -> Maybe Int -> Maybe Int
-- without !-notation
-- m_add x y = do x' <- x
--                y' <- y
--                pure (x + y)
-- with !-notation
m_add x y = pure (!x + !y)

-- ! can be thought of like a prefix function with this type:
--
-- (!) : m a -> a

-- Another convenient syntax is the idiom bracket. idiom bracket makes writing
-- Applicative code cleaner:

m_add' : Maybe Int -> Maybe Int -> Maybe Int
-- without idiom bracket:
-- m_add' x y = pure (+) <*> x <*> y
-- with idiom bracket:
m_add' x y = [| x + y |]

-- idris values are by default strict, Lazy values must be declared explicitly.
--
-- Lazy : Type -> Type

my_if : Bool -> Lazy a -> Lazy a -> a
my_if b x y = if b then x else y

-- when we acquire a value of 'a' where we have a 'Lazy a', it will
-- automatically be evaluated.
--
-- similarly, when we acquire a 'Lazy a' where we have an 'a'-typed expr, the
-- expr will be converted into a unresolved lazy value of type 'Lazy a'

-- function definitions are evaluated in the order they are defined therefore
-- you cannot write plain functions depending on each other directly (you can
-- define recursive function with no problem, though). 'mutual' syntax can be
-- used in this situation, in a 'mutual' block, first the type declarations are
-- added, then the function definitions.

fact' : Nat -> Nat
fact' Z = 1
fact' (S n) = (S n) * fact' n

mutual
  even : Nat -> Bool
  even Z = True
  even (S k) = odd k

  odd : Nat -> Bool
  odd Z = False
  odd (S k) = even k

-- infinte data structure are called co-data types.
--
-- codata-types will gets translated into same as a kind of 'Lazy' data types
namespace StreamCodata
  codata Stream' : Type -> Type where
    (::) : (e : a) -> Stream' a -> Stream' a

-- is the same as

namespace StreamInfData
  data Stream'' : Type -> Type where
    (::) : (e : a) -> Inf (Stream'' a) -> Stream'' a

-- since (::) cannot be defined twice under the same namespace, so here we
-- define them under two namespaces. They can be used without distinguishing
-- explicitly since they differ by the type of the second argument.

-- Inf is mostly the same as Lazy except some nauce differences on their effects
-- on totality.

-- just as a canonical example of typical dependent-type language, there's a
-- built-in Vect data structure is the list parametrized with its length.
-- Defined as below:

data Vect' : (n : Nat) -> a -> Type where
  Nil  : Vect' 0 a
  (::) : a -> Vect' n a -> Vect' (S n) a

-- Tuple syntax (a,b), as both type and value, is a syntatic sugar again.
-- (a, b) as a type is Pair a b; (a, b) as a value is MkPair a b

-- There's another interesting data structure called DPair (Dependent Pair). Defined as:

data DPair' : (a : Type) -> (P : a -> Type) -> Type where
  MkDPair' : {P : a -> Type} -> (x : a) -> P x -> DPair' a P

-- where the second element is a value whose type depends on the value of the
-- first argument. In type theory this type is referred to as `Sigma types'.
--
-- There's, again, a syntatic sugar for DPair: (a:A ** p) stands for MkDPair a p

vec : (n : Nat ** Vect' n Int)
vec = (_ ** [1,2])
-- we can write `_' in place of values which the typechecker can infer
-- automatically.

vec' : DPair Nat (\n => Vect' n Int)
vec' = MkDPair _ [3,4]
-- the same, desugared version.


module Main

import BTree
import Data.List
import Data.Stream

treesort : Ord a => List a -> List a
treesort xs = BTree.toList $ toTree xs

lincong : Integer -> Stream Integer
lincong = tail . (iterate (\n => (1103515245 * (fromInteger n) + 12345) `mod` 2147483648))

randishInts : Nat -> Integer -> List Integer
randishInts size seed = take size $ lincong seed

mylast : List a -> Maybe a
mylast [] = Nothing
mylast [x] = Just x
mylast (x::xs) = mylast xs

doSort : Nat -> IO ()
doSort Z     = putStrLn "Done"
doSort (S k) = do let xs = treesort $ randishInts 30000 $ natToInteger k
                  -- get last elem to make sure compiler doesn't optimise away the sort
                  putStrLn $ show $ mylast xs
                  doSort k

main : IO ()
main = do max <- getLine
          doSort (integerToNat (cast max))


|||
module Toolkit.Data.Graph.EdgeBounded.DegreeCommon

import Decidable.Equality

import Data.String
import Data.List.Elem
import Data.List.Quantifiers

import Toolkit.Decidable.Do
import Toolkit.Decidable.Informative

import Toolkit.Data.Nat
import Toolkit.Data.Pair
import Toolkit.Data.List.Size
import Toolkit.Data.List.Occurs.Does

%default total

namespace HasDegree

  public export
  data DegreeType = I | O

  public export
  record Error where
    constructor MkError
    vertexID : Nat
    degType  : DegreeType
    values   : Occurs.Error

-- [ EOF ]


module SimpleData

data Fwd a = FNil | (<|) a (Fwd a)
data Bwd a = BNil | (|>) (Bwd a) a

data Tree n l
  = Leaf l
  | Node (Tree n l) n (Tree n l)


= Preface

== Welcome

This electronic book is a course on _Software Foundations_, the mathematical
underpinnings of reliable software. Topics include basic concepts of logic,
computer-assisted theorem proving, the Idris programming language, functional
programming, operational semantics, Hoare logic, and static type systems. The
exposition is intended for a broad range of readers, from advanced
undergraduates to PhD students and researchers. No specific background in logic
or programming languages is assumed, though a degree of mathematical maturity
will be helpful.

The principal novelty of the course is that it is one hundred percent formalized
and machine-checked: the entire text is Literate Idris. It is intended to be
read alongside an interactive session with Idris. All the details in the text
are fully formalized in Idris, and the exercises are designed to be worked using
Idris.

The files are organized into a sequence of core chapters, covering about one
semester's worth of material and organized into a coherent linear narrative,
plus a number of "appendices" covering additional topics. All the core chapters
are suitable for both upper-level undergraduate and graduate students.

== Overview

Building reliable software is hard. The scale and complexity of modern systems,
the number of people involved in building them, and the range of demands placed
on them render it extremely difficult to build software that is even
more-or-less correct, much less 100% correct. At the same time, the increasing
degree to which information processing is woven into every aspect of society
continually amplifies the cost of bugs and insecurities.

Computer scientists and software engineers have responded to these challenges by
developing a whole host of techniques for improving software reliability,
ranging from recommendations about managing software projects and organizing
programming teams (e.g., extreme programming) to design philosophies for
libraries (e.g., model-view-controller, publish-subscribe, etc.) and programming
languages (e.g., object-oriented programming, aspect-oriented programming,
functional programming, ...) to mathematical techniques for specifying and
reasoning about properties of software and tools for helping validate these
properties.

The present course is focused on this last set of techniques. The text weaves
together five conceptual threads:

1. basic tools from _logic_ for making and justifying precise claims about
   programs;
2. the use of _proof assistants_ to construct rigorous logical arguments;

3. the idea of _functional programming_, both as a method of programming that
   simplifies reasoning about programs and as a bridge between programming and
   logic;

4. formal techniques for _reasoning about the properties of specific programs_
   (e.g., the fact that a sorting function or a compiler obeys some formal
   specification); and

5. the use of _type systems_ for establishing well-behavedness guarantees for
   _all_ programs in a given programming language (e.g., the fact that
   well-typed Java programs cannot be subverted at runtime).

Each of these topics is easily rich enough to fill a whole course in its own
right, so tackling all of them together naturally means that much will be left
unsaid. Nevertheless, we hope readers will find that the themes illuminate and
amplify each other and that bringing them together creates a foundation from
which it will be easy to dig into any of them more deeply. Some suggestions for
further reading can be found in the [Postscript] chapter. Bibliographic
information for all cited works can be found in the [Bib] chapter.

=== Logic

Logic is the field of study whose subject matter is _proofs_ -- unassailable
arguments for the truth of particular propositions. Volumes have been written
about the central role of logic in computer science. Manna and Waldinger called
it "the calculus of computer science," while Halpern et al.'s paper _On the
Unusual Effectiveness of Logic in Computer Science_ catalogs scores of ways in
which logic offers critical tools and insights. Indeed, they observe that "As a
matter of fact, logic has turned out to be significantly more effective in
computer science than it has been in mathematics. This is quite remarkable,
especially since much of the impetus for the development of logic during the
past one hundred years came from mathematics."

In particular, the fundamental notion of inductive proofs is ubiquitous in all
of computer science. You have surely seen them before, in contexts from discrete
math to analysis of algorithms, but in this course we will examine them much
more deeply than you have probably done so far.

=== Proof Assistants

The flow of ideas between logic and computer science has not been in just one
direction: CS has also made important contributions to logic. One of these has
been the development of software tools for helping construct proofs of logical
propositions. These tools fall into two broad categories:

  - _Automated theorem provers_ provide "push-button" operation: you give them a
    proposition and they return either _true_, _false_, or _ran out of time_.
    Although their capabilities are limited to fairly specific sorts of
    reasoning, they have matured tremendously in recent years and are used now
    in a huge variety of settings. Examples of such tools include SAT solvers,
    SMT solvers, and model checkers.

  - _Proof assistants_ are hybrid tools that automate the more routine aspects
    of building proofs while depending on human guidance for more difficult
    aspects. Widely used proof assistants include Isabelle, Agda, Twelf, ACL2,
    PVS, Coq, and Idris among many others.

This course is based around Coq, a proof assistant that has been under
development, mostly in France, since 1983 and that in recent years has attracted
a large community of users in both research and industry. Coq provides a rich
environment for interactive development of machine-checked formal reasoning. The
kernel of the Coq system is a simple proof-checker, which guarantees that only
correct deduction steps are performed. On top of this kernel, the Coq
environment provides high-level facilities for proof development, including
powerful tactics for constructing complex proofs semi-automatically, and a large
library of common definitions and lemmas.

Coq has been a critical enabler for a huge variety of work across computer
science and mathematics:

  - As a _platform for modeling programming languages_, it has become a standard
    tool for researchers who need to describe and reason about complex language
    definitions. It has been used, for example, to check the security of the
    JavaCard platform, obtaining the highest level of common criteria
    certification, and for formal specifications of the x86 and LLVM instruction
    sets and programming languages such as C.

  - As an _environment for developing formally certified software_, Coq has been
    used, for example, to build CompCert, a fully-verified optimizing compiler
    for C, for proving the correctness of subtle algorithms involving floating
    point numbers, and as the basis for CertiCrypt, an environment for reasoning
    about the security of cryptographic algorithms.

  - As a _realistic environment for functional programming with dependent
    types_, it has inspired numerous innovations. For example, the Ynot project
    at Harvard embedded "relational Hoare reasoning" (an extension of the _Hoare
    Logic_ we will see later in this course) in Coq.

  - As a _proof assistant for higher-order logic_, it has been used to validate
    a number of important results in mathematics. For example, its ability to
    include complex computations inside proofs made it possible to develop the
    first formally verified proof of the 4-color theorem. This proof had
    previously been controversial among mathematicians because part of it
    included checking a large number of configurations using a program. In the
    Coq formalization, everything is checked, including the correctness of the
    computational part. More recently, an even more massive effort led to a Coq
    formalization of the Feit-Thompson Theorem -- the first major step in the
    classification of finite simple groups.

By the way, in case you're wondering about the name, here's what the official
Coq web site says: "Some French computer scientists have a tradition of naming
their software as animal species: Caml, Elan, Foc or Phox are examples of this
tacit convention. In French, 'coq' means rooster, and it sounds like the
initials of the Calculus of Constructions (CoC) on which it is based." The
rooster is also the national symbol of France, and C-o-q are the first three
letters of the name of Thierry Coquand, one of Coq's early developers.

=== Functional Programming

The term _functional programming_ refers both to a collection of programming
idioms that can be used in almost any programming language and to a family of
programming languages designed to emphasize these idioms, including Haskell,
OCaml, Standard ML, F#, Scala, Scheme, Racket, Common Lisp, Clojure, Erlang,
and Coq.

Functional programming has been developed over many decades -- indeed, its roots
go back to Church's lambda-calculus, which was invented in the 1930s, before
there were even any computers! But since the early '90s it has enjoyed a surge
of interest among industrial engineers and language designers, playing a key
role in high-value systems at companies like Jane St. Capital, Microsoft,
Facebook, and Ericsson.

The most basic tenet of functional programming is that, as much as possible,
computation should be _pure_, in the sense that the only effect of execution
should be to produce a result: the computation should be free from _side
effects_ such as I/O, assignments to mutable variables, redirecting pointers,
etc. For example, whereas an _imperative_ sorting function might take a list of
numbers and rearrange its pointers to put the list in order, a pure sorting
function would take the original list and return a _new_ list containing the
same numbers in sorted order.

One significant benefit of this style of programming is that it makes programs
easier to understand and reason about. If every operation on a data structure
yields a new data structure, leaving the old one intact, then there is no need
to worry about how that structure is being shared and whether a change by one
part of the program might break an invariant that another part of the program
relies on. These considerations are particularly critical in concurrent
programs, where every piece of mutable state that is shared between threads is a
potential source of pernicious bugs. Indeed, a large part of the recent interest
in functional programming in industry is due to its simpler behavior in the
presence of concurrency.

Another reason for the current excitement about functional programming is
related to the first: functional programs are often much easier to parallelize
than their imperative counterparts. If running a computation has no effect other
than producing a result, then it does not matter _where_ it is run. Similarly,
if a data structure is never modified destructively, then it can be copied
freely, across cores or across the network. Indeed, the "Map-Reduce" idiom,
which lies at the heart of massively distributed query processors like Hadoop
and is used by Google to index the entire web is a classic example of functional
programming.

For this course, functional programming has yet another significant attraction:
it serves as a bridge between logic and computer science. Indeed, Coq itself can
be viewed as a combination of a small but extremely expressive functional
programming language plus with a set of tools for stating and proving logical
assertions. Moreover, when we come to look more closely, we find that these two
sides of Coq are actually aspects of the very same underlying machinery -- i.e.,
_proofs are programs_.

=== Program Verification

Approximately the first third of the book is devoted to developing the
conceptual framework of logic and functional programming and gaining enough
fluency with Coq to use it for modeling and reasoning about nontrivial
artifacts. From this point on, we increasingly turn our attention to two broad
topics of critical importance to the enterprise of building reliable software
(and hardware): techniques for proving specific properties of particular
_programs_ and for proving general properties of whole programming _languages_.

For both of these, the first thing we need is a way of representing programs as
mathematical objects, so we can talk about them precisely, together with ways of
describing their behavior in terms of mathematical functions or relations. Our
tools for these tasks are _abstract syntax_ and _operational semantics_, a
method of specifying programming languages by writing abstract interpreters. At
the beginning, we work with operational semantics in the so-called "big-step"
style, which leads to somewhat simpler and more readable definitions when it is
applicable. Later on, we switch to a more detailed "small-step" style, which
helps make some useful distinctions between different sorts of "nonterminating"
program behaviors and is applicable to a broader range of language features,
including concurrency.

The first programming language we consider in detail is _Imp_, a tiny toy
language capturing the core features of conventional imperative programming:
variables, assignment, conditionals, and loops. We study two different ways of
reasoning about the properties of Imp programs.

First, we consider what it means to say that two Imp programs are _equivalent_
in the intuitive sense that they yield the same behavior when started in any
initial memory state. This notion of equivalence then becomes a criterion for
judging the correctness of _metaprograms_ -- programs that manipulate other
programs, such as compilers and optimizers. We build a simple optimizer for Imp
and prove that it is correct.

Second, we develop a methodology for proving that particular Imp programs
satisfy formal specifications of their behavior. We introduce the notion of
_Hoare triples_ -- Imp programs annotated with pre- and post-conditions
describing what should be true about the memory in which they are started and
what they promise to make true about the memory in which they terminate -- and
the reasoning principles of _Hoare Logic_, a "domain-specific logic" specialized
for convenient compositional reasoning about imperative programs, with concepts
like "loop invariant" built in.

This part of the course is intended to give readers a taste of the key ideas and
mathematical tools used in a wide variety of real-world software and hardware
verification tasks.

=== Type Systems

Our final major topic, covering approximately the last third of the course, is
_type systems_, a powerful set of tools for establishing properties of _all_
programs in a given language.

Type systems are the best established and most popular example of a highly
successful class of formal verification techniques known as _lightweight formal
methods_. These are reasoning techniques of modest power -- modest enough that
automatic checkers can be built into compilers, linkers, or program analyzers
and thus be applied even by programmers unfamiliar with the underlying theories.
Other examples of lightweight formal methods include hardware and software model
checkers, contract checkers, and run-time property monitoring techniques for
detecting when some component of a system is not behaving according to
specification.

This topic brings us full circle: the language whose properties we study in this
part, the _simply typed lambda-calculus_, is essentially a simplified model of
the core of Coq itself!

=== Further Reading

This text is intended to be self contained, but readers looking for a deeper
treatment of a particular topic will find suggestions for further reading in the
[Postscript] chapter.

== Practicalities

=== Chapter Dependencies

A diagram of the dependencies between chapters and some suggested
paths through the material can be found in the file [deps.html].

=== System Requirements

Coq runs on Windows, Linux, and OS X.  You will need:

  - A current installation of Coq, available from the Coq home page. Everything
    should work with version 8.4. (Version 8.5 will _not_ work, due to a few
    incompatible changes in Coq between 8.4 and 8.5.)

  - An IDE for interacting with Coq. Currently, there are two choices:

    - Proof General is an Emacs-based IDE. It tends to be preferred by users who
      are already comfortable with Emacs. It requires a separate installation
      (google "Proof General").

    - CoqIDE is a simpler stand-alone IDE. It is distributed with Coq, so it
      should "just work" once you have Coq installed. It can also be compiled
      from scratch, but on some platforms this may involve installing additional
      packages for GUI libraries and such.

=== Exercises

Each chapter includes numerous exercises. Each is marked with a "star rating,"
which can be interpreted as follows:

  - One star: easy exercises that underscore points in the text and that, for
    most readers, should take only a minute or two. Get in the habit of working
    these as you reach them.

  - Two stars: straightforward exercises (five or ten minutes).

  - Three stars: exercises requiring a bit of thought (ten minutes to half an
    hour).

  - Four and five stars: more difficult exercises (half an hour and up).

Also, some exercises are marked "advanced", and some are marked "optional."
Doing just the non-optional, non-advanced exercises should provide good coverage
of the core material. Optional exercises provide a bit of extra practice with
key concepts and introduce secondary themes that may be of interest to some
readers. Advanced exercises are for readers who want an extra challenge (and, in
return, a deeper contact with the material).

_Please do not post solutions to the exercises in any public place_: Software
Foundations is widely used both for self-study and for university courses.
Having solutions easily available makes it much less useful for courses, which
typically have graded homework assignments. The authors especially request that
readers not post solutions to the exercises anyplace where they can be found by
search engines.

=== Downloading the Coq Files

A tar file containing the full sources for the "release version" of these notes
(as a collection of Coq scripts and HTML files) is available here:

    http://www.cis.upenn.edu/~bcpierce/sf

If you are using the notes as part of a class, you may be given access to a
locally extended version of the files, which you should use instead of the
release version.

== Translations

Thanks to the efforts of a team of volunteer translators, _Software Foundations_
can now be enjoyed in Japanese at [http://proofcafe.org/sf]. A Chinese
translation is underway.


module Syntax

public export
data Expression
  = Numeral Integer
  | Plus Expression Expression
  | Minus Expression Expression
  | Times Expression Expression
  | Divide Expression Expression
  | Negate Expression


module Main

import Control.Monad.State
import Data.Fin
import Data.List
import Data.Nat
import Data.SortedMap
import Data.Vect

data Wire : Type where
  MkWire : Int -> Wire

Eq Wire where
  (MkWire a) == (MkWire b) = a == b

Ord Wire where
  compare (MkWire a) (MkWire b) = compare a b

Show Wire where
  show (MkWire a) = "wire(" ++ show a ++ ")"

data Component : Type where
  Nand : (a : Wire) -> (b : Wire) -> (aNandB : Wire) -> Component
  One : (alwaysOne : Wire) -> Component
  Zero : (alwaysZero : Wire) -> Component
  Observer : (tag : String) -> Wire -> Component
  Relay : (in' : Wire) -> (out : Wire) -> Component
  -- Boot : Wire -> Component

Show Component where
  show (Nand a b o) = show o ++ "=" ++ "~(" ++ show a ++ "&" ++ show b ++ ")"
  show (One w) = show w ++ "=1"
  show (Zero w) = show w ++ "=0"
  show (Observer tag w) = tag ++ "=" ++ show w
  show (Relay i o) = show o ++ "=" ++ show i
  -- show (Boot w) = show w ++ "=<boot>"

Circuit : Type
Circuit = List Component

record BuilderState where
  constructor MkBuilderState
  wireCounter : Int
  circuit : List Component

CircuitBuilder : Type -> Type
CircuitBuilder = State BuilderState

runCircuitBuilder : CircuitBuilder a -> Circuit
runCircuitBuilder = circuit . execState (MkBuilderState 0 [])

newWire : CircuitBuilder Wire
newWire = do
  wire <- gets wireCounter
  modify record { wireCounter $= (+ 1) }
  pure (MkWire wire)

addComponents : List Component -> CircuitBuilder ()
addComponents ts = modify record { circuit $= (ts ++) }

observe : String -> Wire -> CircuitBuilder ()
observe tag w = addComponents [ Observer tag w ]

combinatorial : (Wire -> CircuitBuilder (List Component)) -> CircuitBuilder Wire
combinatorial f = do
  out <- newWire
  comps <- f out
  addComponents comps
  pure out

relay : Wire -> CircuitBuilder Wire
relay w = combinatorial \out =>
  pure [ Relay w out ]

relay_ : Wire -> Wire -> CircuitBuilder ()
relay_ i o = addComponents [ Relay i o ]

delay : Nat -> Wire -> CircuitBuilder Wire
delay 0 w = pure w
delay (S k) w = relay w >>= delay k

-- boot : Wire -> CircuitBuilder ()
-- boot w = addComponents [ Boot w ]

nand : Wire -> Wire -> CircuitBuilder Wire
nand a b = combinatorial \out =>
  pure [ Nand a b out ]

nand_ : Wire -> Wire -> Wire -> CircuitBuilder ()
nand_ a b o = addComponents [ Nand a b o ]

one : CircuitBuilder Wire
one = combinatorial \out =>
  pure [ One out ]

one_ : Wire -> CircuitBuilder ()
one_ w = addComponents [ One w ]

zero : CircuitBuilder Wire
zero = combinatorial \out =>
  pure [ Zero out ]

zero_ : Wire -> CircuitBuilder ()
zero_ w = addComponents [ Zero w ]

not : Wire -> CircuitBuilder Wire
not a = nand a !one

not_ : Wire -> Wire -> CircuitBuilder ()
not_ a na = addComponents [ Nand a !one na ]

and : Wire -> Wire -> CircuitBuilder Wire
and a b = not !(nand a b)

or : Wire -> Wire -> CircuitBuilder Wire
or a b = nand !(not a) !(not b)

xor : Wire -> Wire -> CircuitBuilder Wire
xor a b = and !(nand a b) !(or a b)

nor : Wire -> Wire -> CircuitBuilder Wire
nor a b = not !(or a b)

nor_ : Wire -> Wire -> Wire -> CircuitBuilder ()
nor_ a b o = not_ !(or a b) o

halfAdder : Wire -> Wire -> CircuitBuilder (Wire, Wire)
halfAdder a b = [| (xor a b, and a b) |]

fullAdder : Wire -> Wire -> Wire -> CircuitBuilder (Wire, Wire)
fullAdder a b carryIn = do
  (sum1, carry1) <- halfAdder a b
  (sum2, carry2) <- halfAdder sum1 carryIn
  pure (sum2, !(or carry1 carry2))

Byte : Type
Byte = Vect 8 Wire

dFoldL : {n : Nat}
  -> (0 motive : Nat -> Type)
  -> (forall p. motive p -> a -> motive (S p))
  -> motive 0
  -> Vect n a
  -> motive n
dFoldL {n} motive f acc v = rewrite sym $ plusZeroRightNeutral n in helper acc v
  where
    helper : {q, m : Nat} -> motive m -> Vect q a -> motive (q + m)
    helper acc Nil = acc
    helper {q = S q, m} acc (x :: xs) = rewrite plusSuccRightSucc q m in helper (f acc x) xs

byteAdder : Byte -> Byte -> Wire -> CircuitBuilder (Byte, Wire)
byteAdder as bs carryIn = dFoldL (\n => CircuitBuilder (Vect n Wire, Wire)) (\ms, ab => f !ms ab) (pure (Nil, carryIn)) (zipWith (,) as bs)
  where
    f : (Vect n Wire, Wire) -> (Wire, Wire) -> CircuitBuilder (Vect (S n) Wire, Wire)
    f (os, c) (a, b) = do
      (o, c') <- fullAdder a b c
      pure (snoc os o, c')

binsToConsts : Vect n (Fin 2) -> CircuitBuilder (Vect n Wire)
binsToConsts = traverse \b =>
  case b of
    1 => one
    0 => zero

-- binsToBootedWires : Vect n (Fin 2) -> CircuitBuilder (Vect n Wire)
-- binsToBootedWires = traverse \b => do
--   w <- newWire
--   if b == 1 then boot w else pure ()
--   pure w

clock : (halfWidthMinusOne : Nat) -> CircuitBuilder Wire
clock n = do
  w <- newWire
  i <- delay n w
  not_ i w
  pure i

gatedSRLatch_ : (set : Wire) -> (reset : Wire) -> (enable : Wire)
  -> (q : Wire) -> (nq : Wire) -> CircuitBuilder ()
gatedSRLatch_ s r e q nq= do
  s' <- and s e
  r' <- and r e
  nor_ r' nq q
  nor_ s' q nq
  pure ()

gatedSRLatch : (set : Wire) -> (reset : Wire) -> (enable : Wire) -> CircuitBuilder (Wire, Wire)
gatedSRLatch s r e = do
  q <- newWire
  nq <- newWire
  gatedSRLatch_ s r e q nq
  pure (q, nq)

gatedDLatch : (data' : Wire) -> (enable : Wire) -> CircuitBuilder (Wire, Wire)
gatedDLatch d e = gatedSRLatch d !(not d) e

dFlipFlop_ : (data' : Wire) -> (clock : Wire) -> (dataNext : Wire) -> CircuitBuilder ()
dFlipFlop_ d clk dn = do
  (q, nq) <- gatedDLatch d !(not clk)
  dummy <- newWire
  gatedSRLatch_ q nq clk dn dummy

dFlipFlop : (data' : Wire) -> (clock : Wire) -> CircuitBuilder Wire
dFlipFlop d clk = do
  dn <- newWire
  dFlipFlop_ d clk dn
  pure dn

data Signal = High | Low

Show Signal where
  show High = "1"
  show Low = "0"

data CircuitState
  = Valid (SortedMap Wire Signal)
  | Invalid

Show CircuitState where
  show (Valid cstate) = show cstate
  show Invalid = "invalid circuit state"

Semigroup CircuitState where
  Invalid <+> _ = Invalid
  _ <+> Invalid = Invalid
  Valid a <+> Valid b = toCS . sequence $ mergeWith m (map Just a) (map Just b)
    where
      m : Maybe Signal -> Maybe Signal -> Maybe Signal
      m (Just High) (Just High) = Just High
      m (Just Low) (Just Low) = Just Low
      m _ _ = Nothing

      toCS : Maybe (SortedMap Wire Signal) -> CircuitState
      toCS (Just cs) = Valid cs
      toCS Nothing = Invalid

Monoid CircuitState where
  neutral = Valid empty

lookupSignal : Wire -> CircuitState -> Maybe Signal
lookupSignal w (Valid cs) = lookup w cs
lookupSignal w Invalid = Nothing

initialState : Circuit -> CircuitState
initialState = concat . map toMap
  where
    toMap : Component -> CircuitState
    toMap (Nand a b c) = Valid . fromList $ [ (a, Low), (b, Low), (c, Low) ]
    toMap (One w) = Valid . fromList $ [ (w, Low) ]
    toMap (Zero w) = Valid . fromList $ [ (w, Low) ]
    toMap (Observer _ w) = Valid . fromList $ [ (w, Low) ]
    toMap (Relay i o) = Valid . fromList $ [ (i, Low), (o, Low) ]
    -- toMap (Boot w) = Valid . fromList $ [ (w, High) ]

count : (n : Nat) -> Vect n Nat
count 0 = Nil
count (S n) = snoc (count n) n

runCircuit : Circuit -> CircuitState-> CircuitState
runCircuit comps cstate = concat . map drive $ comps
  where
    signalNand : Signal -> Signal -> Signal
    signalNand High High = Low
    signalNand High Low = High
    signalNand Low High = High
    signalNand Low Low = High

    drive : Component -> CircuitState
    drive (Nand a b o) =
      let as = lookupSignal a cstate
          bs = lookupSignal b cstate
      in case (as, bs) of
        (Just asig, Just bsig) => Valid . fromList $ [ (o, signalNand asig bsig) ]
        _ => Invalid
    drive (One w) = Valid . fromList $ [ (w, High) ]
    drive (Zero w) = Valid . fromList $ [ (w, Low) ]
    drive (Observer _ w) = Valid empty
    drive (Relay i o) =
      case lookupSignal i cstate of
        Just isig => Valid . fromList $ [ (o, isig) ]
        Nothing => Invalid
    -- drive (Boot w) = Valid empty

Observations : Type
Observations = List (String, Signal)

getObservations : Circuit -> CircuitState -> Observations
getObservations comps (Valid cstate) = concatMap ob $ comps
  where
    ob : Component -> List (String, Signal)
    ob (Observer tag w) =
      case lookup w cstate of
        Just sig => [ (tag, sig) ]
        Nothing => []
    ob _ = []
getObservations _ Invalid = []

putObservationsLn : Observations -> IO ()
putObservationsLn = (>> putChar '\n') . traverse f
  where
    f : (String, Signal) -> IO ()
    f (tag, sig) = putStr $ tag ++ "=" ++ show sig ++ ", "

exampleAdder : Circuit
exampleAdder = runCircuitBuilder $ do
  const2 <- binsToConsts [ 0, 1, 0, 0, 0, 0, 0, 0 ]
  const3 <- binsToConsts [ 1, 1, 0, 0, 0, 0, 0, 0 ]
  (shouldBe5, shouldBe0) <- byteAdder const2 const3 !zero
  let indexed5 = zipWith (,) shouldBe5 (count 8)
  traverse (\(w, n) => observe ("out[" ++ show n ++ "]") w) indexed5
  observe "out_carry" shouldBe0

exampleClock : Nat -> Circuit
exampleClock n = runCircuitBuilder $ do
  c <- clock n
  observe "clock" c

exampleLatch : Circuit
exampleLatch = runCircuitBuilder $ do
  (q, nq) <- gatedSRLatch !zero !one !one
  observe "q" q
  observe "~q" nq

exampleDff : Circuit
exampleDff = runCircuitBuilder $ do
  clk <- clock 40
  observe "clk" clk
  dFlipFlop !one clk >>= observe "dn"

main : IO ()
main =
  let exm = exampleDff
  in map (const ()) . traverse (putObservationsLn . getObservations exm) . iterateN 200 (runCircuit exm) . initialState $ exm


identity : (a : Type) -> a -> a
identity a = id

identityL :
  (a, b : Type )
  -> (f : a -> b)
  -> (identity b) . f = f
identityL a b f = Refl

identityR :
  (a, b : Type )
  -> (f : a -> b)
  -> f = (identity b) . f
identityR a b f = Refl


module Typing.Infer

import public Typing.Term
import Syntax.Term as Untyped

import Control.Monad.State.State
import Control.Monad.State.Interface
import Control.Monad.Identity
import Control.Monad.Error.Either
import Control.Monad.Error.Interface
import Control.Monad.Trans

import Data.SortedMap
import Data.List

-- Some helper functions

||| It's like A / B to multiset
complement : Eq a => List a -> List a -> List a
complement = foldl (flip Data.List.delete)

mapMap : Ord k => (v -> n) -> SortedMap k v -> SortedMap k n
mapMap f sMap =
    let vals = toList sMap in
    foldr (\c => insert (Builtin.fst c) (f $ Builtin.snd c)) empty vals

||| Substitutes freeVars for concrete types

Subst : Type
Subst = SortedMap String Ty

emptySubst : Subst
emptySubst = empty

||| Type enviroment that stores all mapping from strings to schemas
data Context = MkCtx (SortedMap (List String) Schema)

remove : Context -> List String -> Context
remove (MkCtx ctx) str = MkCtx (delete str ctx)

findVar : (List String) -> Context -> Maybe Schema
findVar key (MkCtx ctx) = lookup key ctx

insert : Context -> (List String) -> Schema -> Context
insert (MkCtx ctx) key val = MkCtx (insert key val ctx)

-- Apply and freevars implementation
interface Application a where
  freeVars : a -> (List String)
  apply : Subst -> a -> a

Application Ty where
  freeVars (TyVar r n) = [n]
  freeVars (TyPoly r path ty) = freeVars ty
  freeVars (TySimple r s) = []
  freeVars (TyArrow r a b) = (freeVars a) `union` (freeVars b)

  apply subs t@(TyVar r n) =
    case lookup n subs of
      Just val => val
      Nothing  => t

  apply subs (TyArrow r arg ret) = TyArrow r (apply subs arg) (apply subs ret)
  apply subs (TyPoly r name type) = TyPoly r name (apply subs type)
  apply subs (TySimple r t) = TySimple r t

Application Schema where
  freeVars (MkSchema binded ty)   = freeVars ty `complement` binded
  apply subs (MkSchema binded ty) =
    let bindFreeSubs = foldr Data.SortedMap.delete subs binded in
    MkSchema binded (apply bindFreeSubs ty)

Application a => Application (List a) where
  apply      = map . apply
  freeVars   = foldr union [] . map freeVars

Application Context where
  freeVars (MkCtx env) = freeVars (values env)
  apply subs (MkCtx env) = MkCtx (mapMap (apply subs) env)

composeSubst : Subst -> Subst -> Subst
composeSubst s1 s2 = (mapMap (apply s1) s2) `mergeLeft` (s1)

-- Some functions of Hindley milner

TI : Type -> Type
TI = StateT Int (EitherT String Identity)

newTyVar : TI Ty
newTyVar = do
  res <- get
  put (res + 1)
  pure (TyVar emptyRange (cast $ res + 1))

generalize : Context -> Ty -> Schema
generalize ctx ty =
  let vars = freeVars ty `complement` freeVars ctx in
  MkSchema vars ty

instantiate : Schema -> TI Ty
instantiate (MkSchema vars ty) = do
  nvars <- traverse (const newTyVar) vars
  let subst = fromList $ zip vars nvars
  pure (apply subst ty)

-- Unification

isJust : Maybe a -> Bool
isJust a = case a of
  Just a => True
  _ => False

bindVar : String -> Ty -> TI Subst
bindVar name (TyVar r n) = empty
bindVar name other =
  if isJust $ find (== name) (freeVars other)
    then pure $ insert name other empty
    else pure $ insert name other empty

unify : Ty -> Ty -> TI Subst

unify (TyArrow r arg fun) (TyArrow r' arg' fun') = do
  fstSub <- unify arg arg'
  sndSub <- unify fun fun'
  pure (fstSub `composeSubst` sndSub)

unify (TyVar r u) t = bindVar u t
unify t (TyVar r u) = bindVar u t

unify (TySimple r a) (TySimple r' b) =
  if a == b
    then pure empty
    else lift $ throwE ("Cannot unify '" ++ a ++ "' and '" ++ b ++ "'")

unify a b = lift $ throwE ("Cannot unify '" ++ (show a) ++ "' and '" ++ (show b) ++ "'")

-- Inference

pathToList : Path -> List String
pathToList path =
  case path of
    (PDot r (MkName _ str) path) => (pathToList path)
    (PName r str)                => [str]

getVar : Context -> Path -> TI Ty
getVar ctx path =
  let listPath = pathToList path in
  case findVar listPath ctx of
    Just schema => do
      res <- instantiate schema
      pure res
    Nothing     => lift $ throwE ("Cannot find variable: '" ++ (show path) ++ "'")

getTy : Types -> Ty
getTy (TSimple r s)    = TySimple r s
getTy (TArrow r a b)   = TyArrow r (getTy a) (getTy b)
getTy (TPoly r path n) = TyPoly r path (getTy n)
getTy (TVar r a)       = TyVar r a

insertSchema : Context -> (List String) -> Schema -> Context
insertSchema ctx name schema = insert (remove ctx name) name schema

interface Infer e where
  infer : Context -> e -> TI (Subst, Ty)

Infer Literal where
  infer ctx (LStr r _) = pure (empty, TySimple r "Text")
  infer ctx (LInt r _) = pure (empty, TySimple r "Int" )

Infer Expr where
  infer ctx (ELit r lit) = infer ctx lit

  infer ctx (EId path) =
    let listPath = pathToList path in
    case findVar listPath ctx of
      Just schema => do
        res <- instantiate schema
        pure (empty, res)
      Nothing     => lift $ throwE ("Cannot find variable: '" ++ (show path) ++ "'")

  infer ctx (ELambda r (MkName r2 name) expr) = do
    ty <- newTyVar
    let ctxWithArg = insertSchema ctx [name] (MkSchema [] ty)
    (s1, t1) <- infer ctxWithArg expr
    pure (s1, TyArrow r (apply s1 ty) t1)

  infer ctx (ECall r fun expr) = do
    tyRes       <- newTyVar
    (s1, tyFun) <- infer ctx fun
    (s2, tyArg) <- infer (apply s1 ctx) expr
    s3          <- unify (apply s2 tyFun) (TyArrow r tyArg tyRes)
    pure ((s3 `composeSubst` s2) `composeSubst` s1, apply s3 tyRes)

  infer ctx (EDo r (exprs@(h :: tl))) = do
    let lastExpr    = last exprs
    let returnsVoid = init exprs
    (subst, ty) <- infer ctx lastExpr
    subTypeList <- traverse (infer ctx) returnsVoid
    substList   <- traverse (unify (TySimple emptyRange "Unit")) (map snd subTypeList)
    let voidSub   = foldl composeSubst empty substList
    let lastSub   = subTypeList
    pure (subst `composeSubst` voidSub, ty)

  infer ctx (EDo r []) = pure (empty, TySimple r "Unit")

  infer ctx (ELet r (MkName r2 name) val expr) = do
    (s0, tyVal)  <- infer ctx val
    let s0WithArg = insertSchema (apply s0 ctx) [name] (MkSchema [] tyVal)
    (s1, tyExpr) <- infer s0WithArg expr
    pure (s1, tyExpr)

  infer ctx e = lift $ throwE ("Not implemented")

Infer Def where
  infer ctx (Define name Nothing expr) = do
    (s1, ty) <- infer ctx expr
    pure (s1, ty)

  infer ctx (Define name (Just ret) expr) = do
    (s1, ty) <- infer ctx expr
    s2 <- unify (apply s1 (getTy ret)) ty
    pure (s2, ty)

public export
runInference : Def -> Either String (Subst, Ty)
runInference e =
  let ctx = (insert ["unit"] (MkSchema [] (TySimple emptyRange "Unit")) empty) in
  let (Id res) = runEitherT $ evalStateT 0 (infer (MkCtx ctx) e) in
  res


module MaybeFin

import Data.Fin

%default total
%access public

data MaybeFin : Nat -> Type where
  NoFin : MaybeFin Z
  SomeFin : Fin (S k) -> MaybeFin (S k)

instance Cast (MaybeFin n) (Maybe (Fin n)) where
  cast NoFin = Nothing
  cast (SomeFin x) = Just x


module Twicer

import public Numeric

%default total

-- TODO: fix the hole ?pr by using even nat instead of integer

public export
||| Guaranteed to produce a value divisible by 2
twicer : Integer -> EvenInteger
twicer b = ((2 * wfb) ** (Factor (wfb ** (?pr)))) where
  wfb : WFInt
  wfb = cast b