module Compo1

import Incrementer
import Twicer

%default total

-- Realized (twicer . incrementer).
rlz_compo1_attrs : RealizedAttributes
rlz_compo1_attrs = MkRealizedAttributes (MkCosts 300 30 3) 0.9
-- The following does not work because 301 ≠ 200+100
-- rlz_compo1_attrs = MkRealizedAttributes (MkCosts 301 30 3) 0.9
rlz_compo1 : RealizedFunction (Int -> Int) Compo1.rlz_compo1_attrs
rlz_compo1 = compose rlz_twicer rlz_incrementer


module Data.Prim.Bits16

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

%default total

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

||| Lower bound of `Bits16`
public export
MinBits16 : Bits16
MinBits16 = 0

||| Upper bound of `Bits16`
public export
MaxBits16 : Bits16
MaxBits16 = 0xffff

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

||| Not value of type `Bits16` is less than zero.
export
0 Not_LT_MinBits16 : m < 0 -> Void
Not_LT_MinBits16 = GTE_not_LT (GTE_MinBits16 m)

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

||| Not value of type `Bits16` is greater than `MaxBits16`
export
0 Not_GT_MaxBits16 : m > MaxBits16 -> Void
Not_GT_MaxBits16 = LTE_not_GT (LTE_MaxBits16 m)

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

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

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

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

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

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

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

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

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


interface A where
  x : Nat
  f : {auto pf : x = 0} -> ()


module GameMessage
import GameState
import IdrisNet.PacketLang
import IdrisNet.UDP.UDPClient
import Effect.StdIO

-- Data structure communicated between aux thread and master thread,
-- signifying some update.
data GameMessage = UpdateRemotePaddle Bool Bool Int Int -- Up pressed, down pressed, x, y
                 | UpdateRemoteBallPos PongBall

ballUpdate : PacketLang
ballUpdate = with PacketLang do
  x <- bits 32
  y <- bits 32
  xv_neg <- bool
  x_vel <- bits 32
  yv_neg <- bool
  y_vel <- bits 32
  bool -- Stuck to paddle?
  bool -- Last hit left

paddleUpdate : PacketLang
paddleUpdate = with PacketLang do
  bool
  bool
  bits 32 -- X
  bits 32 -- Y

statusUpdate : PacketLang
statusUpdate = with PacketLang do
  is_ball <- bool -- True if ball update, false if paddle
  p_if is_ball then ballUpdate else paddleUpdate

mkMessage : (mkTy statusUpdate) -> GameMessage
mkMessage (True ## x ## y ## xv_neg ## xv ## yv_neg ## yv ## stuck ## left) =
    UpdateRemoteBallPos $ MkPongBall (val x, val y) xv' yv' stuck left
  where xv' = if xv_neg then ((val xv) * (-1)) else (val xv)
        yv' = if yv_neg then ((val yv) * (-1)) else (val yv)

mkMessage (False ## up ## down ## x ## y) = UpdateRemotePaddle up down (val x) (val y)

sendBallUpdate : { [STATE GameState, STDIO, UDPCLIENT] } Eff Bool
sendBallUpdate = do
    st <- get
    let sa = pongRemoteAddr st
    let p = pongRemotePort st
    case m_pckt (pongBall st) of
      Just pckt => do IdrisNet.UDP.UDPClient.udpWritePacket sa p statusUpdate pckt
                      return True
      Nothing => return False
  where m_pckt : PongBall -> (Maybe (mkTy statusUpdate))
        m_pckt pb = with Monad do
                       let ((x, y), xv, yv) =
                         (pongBallPos pb, pongBallXVel pb, pongBallYVel pb)
                       b_x <- mkBounded 32 x
                       b_y <- mkBounded 32 y
                       let neg_xv = xv < 0
                       b_xv <- mkBounded 32 (abs xv)
                       let neg_yv = yv < 0
                       b_yv <- mkBounded 32 (abs yv)
                       return (True ## b_x ## b_y ## neg_xv ## b_xv ##
                               neg_yv ## b_yv ## (pongBallStuck pb) ## (pongBallHitLeft pb))

sendPaddleUpdate : { [STATE GameState, UDPCLIENT] } Eff Bool
sendPaddleUpdate = do
    st <- get
    let sa = pongRemoteAddr st
    let p = pongRemotePort st
    let up_pressed = pongIsUpPressed st
    let down_pressed = pongIsDownPressed st
    case m_pckt up_pressed down_pressed !getLocalPaddlePos of
      Just pckt => do IdrisNet.UDP.UDPClient.udpWritePacket sa p statusUpdate pckt
                      return True
      Nothing => return False
  where m_pckt : Bool -> Bool -> (Int, Int) -> (Maybe (mkTy statusUpdate))
        m_pckt up_pressed down_pressed (x, y) = with Monad do
          b_x <- mkBounded 32 x
          b_y <- mkBounded 32 y
          return (False ## up_pressed ## down_pressed ## b_x ## b_y)


module Circuits.NetList.Main

import System
import System.File

import Data.String
import Data.Fin
import Data.List.Elem
import Data.List1

import Text.Lexer
import Text.Parser

import Toolkit.Data.Location
import Toolkit.Text.Lexer.Run
import Toolkit.Text.Parser.Run

import Toolkit.Data.Graph.EdgeBounded
import Toolkit.Data.Graph.EdgeBounded.HasExactDegree
import Toolkit.Data.List.Occurs.Does

import Circuits.NetList
import Circuits.NetList.Pretty

netlist : (fname : String)
                -> NetList ()
netlist fname
  = do putStrLn "// LOG : Starting NetList "

       ast <- fromFile fname

       log "// \{show ast}"

       log "// LOG : Parsing Successful"

       term <- Design.check ast

       log "// \{show term}"

       log "// LOG : Type Checking Complete"

       prf <- isSound term

       log "// LOG : Soundness Check Complete"

       putStrLn ((showGraph . fst . getGraph) prf)

       log "// LOG : BYE"

main : IO Unit
main
  = do fname <- processArgs !getArgs
       run (netlist fname)

-- [ EOF ]


record Votes where
       constructor MkVotes
       upvotes : Integer
       downvotes : Integer

record Article where
       constructor MkArticle
       title : String
       url : String
       score : Votes

initPage : (title : String) -> (url : String) -> Article
initPage title url = MkArticle title url (MkVotes 0 0)

badSite : Article
badSite = MkArticle "Bad Page" "http://example.com/bad" (MkVotes 5 47)

goodSite : Article
goodSite = MkArticle "Good Page" "http://example.com/good" (MkVotes 101 7)

-- Exercise 3

getScore : Article -> Integer
getScore article = upvotes (score article) - downvotes (score article)

-- Exercise 4

addUpvote : Article -> Article
addUpvote = record { score->upvotes $= (+1) }

addDownvote : Article -> Article
addDownvote = record { score->downvotes $= (+1) }


module Quantities.Screen

import Quantities.Core
import Quantities.SIBaseQuantities
import Quantities.ImperialUnits
import Quantities.SIBaseUnits

%default total
%access public export

ScreenLength : Dimension
ScreenLength = MkDimension "ScreenLength"

Pixel : ElemUnit ScreenLength
Pixel = MkElemUnit "px" 1
Px : ElemUnit ScreenLength
Px = Pixel

ScreenArea : Quantity
ScreenArea = ScreenLength ^ 2
ScreenEstate : Quantity
ScreenEstate = ScreenArea

ScreenResolution : Quantity
ScreenResolution = ScreenLength </> Length

PixelPerCentimetre : ElemUnit ScreenResolution
PixelPerCentimetre = < one "ppcm" equals 1 (Pixel <//> Centimetre) >
PixelPerCentimeter : ElemUnit ScreenResolution
PixelPerCentimeter = PixelPerCentimetre
Ppcm : ElemUnit ScreenResolution
Ppcm = PixelPerCentimetre

PixelPerInch : ElemUnit ScreenResolution
PixelPerInch = < one "ppi" equals 1 (Pixel <//> Inch) >
Ppi : ElemUnit ScreenResolution
Ppi = PixelPerInch


module Starfield

-- Background starfield effect

import Effects
import Effect.SDL
import Effect.StdIO
import Effect.State

import Rnd

%access public export

data Starfield : Type where -- for labelling state

StarEff : Type -> Type
StarEff t = { [Starfield ::: STATE (List (Int, Int)), RND] } Eff t

initStarfield : List (Int, Int) -> Nat -> StarEff ()
initStarfield acc Z = Starfield :- put acc
initStarfield acc n
    = do x <- rndInt 0 639
         y <- rndInt 0 479
         initStarfield ((x, y) :: acc) (minus n 1)

updateStarfield : StarEff ()
updateStarfield = do xs <- Starfield :- get
                     xs' <- upd [] xs
                     Starfield :- put xs'
 where
  upd : List (Int, Int) -> List (Int, Int) -> { [RND] } Eff (List (Int, Int))
  upd acc [] = pure acc
  upd acc ((x, y) :: xs)
      = if (y > 479) then do
             x <- rndInt 0 639
             upd ((x, 0) :: acc) xs
           else
             upd ((x, y+1) :: acc) xs

drawStarfield : List (Int, Int) -> { [SDL_ON] } Eff ()
drawStarfield [] = pure ()
drawStarfield ((x, y) :: xs) = do line white x y x y
                                  drawStarfield xs


data Elem : Type -> List Type -> Type where

Types : (0 a : Type) -> Eq a => List Type

export
body :  (0 _ : Eq t1)
     => {auto 0 _ : Elem Bool (Types t1)}
     -> (obj : t1)
     -> (obj == obj) === maybe True (const False) (guard (obj == obj))


||| A Reversed List
module Data.SnocList

import Decidable.Equality
import Data.List
import Data.Fin

%default total

infixl 7 <><
infixr 6 <>>

||| 'fish': Action of lists on snoc-lists
public export
(<><) : SnocList a -> List a -> SnocList a
sx <>< [] = sx
sx <>< (x :: xs) = sx :< x <>< xs

||| 'chips': Action of snoc-lists on lists
public export
(<>>) : SnocList a -> List a -> List a
Lin       <>> xs = xs
(sx :< x) <>> xs = sx <>> x :: xs

export
Cast (SnocList a) (List a) where
  cast sx = sx <>> []

export
Cast (List a) (SnocList a) where
  cast xs = Lin <>< xs

||| Transform to a list but keeping the contents in the spine order (term depth).
public export
asList : SnocList type -> List type
asList = (reverse . cast)

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

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

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

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

public export
(++) : (sx, sy : SnocList a) -> SnocList a
(++) sx Lin = sx
(++) sx (sy :< y) = (sx ++ sy) :< y

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

export
Show a => Show (SnocList a) where
  show xs = concat ("[< " :: intersperse ", " (show' [] xs) ++ ["]"])
    where
      show' : List String -> SnocList a -> List String
      show' acc Lin       = acc
      show' acc (xs :< x) = show' (show x :: acc) xs

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

public export
Semigroup (SnocList a) where
  (<+>) = (++)

public export
Monoid (SnocList a) where
  neutral = Lin

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

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

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

  toList = (<>> [])

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

public export
Applicative SnocList where
  pure = (:<) Lin
  fs <*> xs = concatMap (flip map xs) fs

public export
Monad SnocList where
  xs >>= k = concatMap k xs

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

public export
Alternative SnocList where
  empty = Lin
  xs <|> ys = xs ++ ys

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

||| Find the first element of the snoc-list that satisfies the predicate.
public export
find : (a -> Bool) -> SnocList 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 : SnocList 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) -> (xs : SnocList a) -> Maybe $ Fin (length xs)
findIndex _ Lin = Nothing
findIndex p (xs :< x) = if p x
  then Just FZ
  else FS <$> findIndex p xs


import Text.Parser

import Data.Bool

data YamlToken : Type where [external]

Parser : Bool -> Type -> Type
Parser = Grammar (Token YamlToken)

countOcc : {c : Bool} -> Parser c a -> Parser False Nat
countOcc p = rewrite sym $ andFalseFalse (c || False) in
             (S <$ p <*> countOcc p) <|> pure Z


module Main

ok : String -> String
ok s = if length s `mod` 2 == 0 then reverse s else s

main : IO ()
main = putStrLn $ substr 3 2 ( ok "abcdefghjklmnopqrstuvw")


-- This regtest tests for incorrect erasure from underapplied data constructors.

data T : Type where
    C : Nat -> Nat -> Nat -> T

data Q : Type where
    D : (Nat -> T) -> Q

-- The bug was here: (C 3 4) would compile to plain data,
-- not to a function that would expect another (albeit erased) argument.
f : Q
f = D (C 3 4)

proj : Nat -> Q -> Nat -> T
proj    Z  (D f) = f
proj (S n)    q  = proj n q

g : T -> Nat
g (C x y z) = x + y

-- Here, we'd apply the not-a-function to the erased argument 4,
-- which would make the program go wrong.
main : IO ()
main = printLn $ g (proj 3 f 4)


module Extra.String

import Data.Fin
import Data.Nat
import Data.String
import Data.String.Extra
import Data.Vect
import Extra.Binary
import Extra.Fin
import Extra.Proof

-- TODO: I have no idea how should I be implementing this
public export
data NonEmpty : StrM xs -> Type where
  IsNonEmpty : {x : Char} -> {xs : String} -> NonEmpty (StrCons x xs)

export
Uninhabited (NonEmpty StrNil) where
  uninhabited IsNonEmpty impossible

export
hexLower : Fin 16 -> Char
hexLower 0 = '0'
hexLower 1 = '1'
hexLower 2 = '2'
hexLower 3 = '3'
hexLower 4 = '4'
hexLower 5 = '5'
hexLower 6 = '6'
hexLower 7 = '7'
hexLower 8 = '8'
hexLower 9 = '9'
hexLower 10 = 'a'
hexLower 11 = 'b'
hexLower 12 = 'c'
hexLower 13 = 'd'
hexLower 14 = 'e'
hexLower 15 = 'f'

export
hexUpper : Fin 16 -> Char
hexUpper = toUpper . hexLower

||| Turn a `Bits8` into a pair of bytes in `Fin` representation
private
bits8ToBytesFin : Bits8 -> (Fin 16, Fin 16)
bits8ToBytesFin x = divmodFinNZ (bits8ToFin x) 16 SIsNotZ

private
bits8ToHexChars : Bits8 -> (Char, Char)
bits8ToHexChars = bimap hexUpper hexUpper . bits8ToBytesFin

||| Turn a foldable of Bits8 into a upper hex string without '0x' prefix
export
hexString : Foldable f => f Bits8 -> String
hexString = foldr (\x, str => let (a, b) = bits8ToHexChars x in strCons a $ strCons b $ str) ""

export
asciiString : Foldable f => f Bits8 -> String
asciiString = foldr (\x, str => strCons (chr $ cast x) str) ""

||| Turn a string (NO UTF8) into a list of Bits8 by casting the ordinals of the chars of the string
export
unpackVect : (str : String) -> Vect (length str) Char
unpackVect str = case toVect (length str) (unpack str) of
  Nothing => crash "Extra.String.unpackVect: impossible case"
  Just t => t


import Data.Vect

fourInts: Vect 4 Int
fourInts = [1, 2, 2, 4]

sixInts: Vect 6 Int
sixInts = [1, 2, 3, 4, 5, 7]

tenInts: Vect 10 Int
tenInts = fourInts ++ sixInts


module IHateParens

import Data.List

%default total

infixl 0 .|

-- Instead of `f (a b) $ c d` or `f (a b) (c d)` you can write `f .| a b .| c d`
public export %inline
(.|) : (a -> b) -> a -> b
(.|) = id

f : String -> List String -> String
f x = foldr .| (++) . (++ "_") .| "foo" ++ x
--f x = foldr ((++) . (++ "_")) $ "foo" ++ x
--f x = foldr ((++) . (++ "_")) ("foo" ++ x)

f_corr : f "x" ["a", "b", "c"] = "a_b_c_foox"
f_corr = Refl

record Rec where
  constructor MkRec
  oneField : Int
  anotherField : Nat
  yetAnotherField : List Nat

r : Nat -> Rec
r n = MkRec
  .| cast (n + 1)
  .| n + 3
  .| replicate n 5

r_corr : r 4 = MkRec 5 7 [5, 5, 5, 5]
r_corr = Refl


module Data.Cotree

import Data.Colist
import Data.Maybe
import Data.Tree

%default total

--------------------------------------------------------------------------------
--          Cotrees: Potentially infinte trees
--------------------------------------------------------------------------------

mutual
  ||| A potentially infinite rose tree
  public export
  record Cotree (a : Type) where
    constructor MkCotree
    value  : a
    forest : Inf (Coforest a)

  ||| A potentially finit stream of trees
  public export
  Coforest : Type -> Type
  Coforest = Colist . Cotree

public export
singleton : a -> Cotree a
singleton a = MkCotree a Nil

public export
unfold : (f : b -> (a,Colist b)) -> b -> Cotree a
unfold f vb = let (va,bs) = f vb
                   in MkCotree va $ unfoldF bs

  where unfoldF : Colist b -> Coforest a
        unfoldF []       = []
        unfoldF (h :: t) = unfold f h :: unfoldF t

public export
iterate : (f : a -> Colist a) -> a -> Cotree a
iterate f a = unfold (\v => (v, f v)) a

public export
expand : (a -> Colist a) -> Cotree a -> Cotree a
expand f (MkCotree v vs) = let MkCotree v2 vs2 = iterate f v
                            in MkCotree v2 (run vs vs2)
  where run : Coforest a -> Coforest a -> Coforest a
        run []        ys = ys
        run (x :: xs) ys = expand f x :: run xs ys

--------------------------------------------------------------------------------
--          To and from Tree
--------------------------------------------------------------------------------

public export
fromTree : Tree a -> Cotree a
fromTree (MkTree v fo) = MkCotree v (fromForest fo)
  where fromForest : Forest a -> Coforest a
        fromForest []        = []
        fromForest (x :: xs) = fromTree x :: fromForest xs

||| Converts a Cotree to a tree of the given maximum depth and width.
||| The maximum numbers of elements in the tree will be
||| maxWidth ^ maxDepth.
public export
toTree : (maxDepth : Nat) -> (maxWidth : Nat) -> Cotree a -> Tree a
toTree 0     _  (MkCotree v fo) = MkTree v []
toTree (S k) mw (MkCotree v fo) = MkTree v (toForest mw fo)
  where toForest : Nat -> Coforest a -> Forest a
        toForest 0     _         = []
        toForest (S n) []        = []
        toForest (S n) (t :: ts) = toTree k mw t :: toForest n ts

--------------------------------------------------------------------------------
--          Functor and Applicative
--------------------------------------------------------------------------------

public export
mapCotree : (a -> b) -> Cotree a -> Cotree b
mapCotree f (MkCotree v vs) = MkCotree (f v) (mapForest vs)
  where mapForest : Coforest a -> Coforest b
        mapForest []       = []
        mapForest (h :: t) = mapCotree f h :: mapForest t

public export
interleave : Cotree (a -> b) -> Cotree a -> Cotree b
interleave tf@(MkCotree vf fs) ta@(MkCotree va as) =
  MkCotree (vf va) (interleaveFs fs)

  where interleaveAs : Coforest a -> Coforest b
        interleaveAs []       = []
        interleaveAs (h :: t) = interleave tf h :: interleaveAs t

        interleaveFs : Coforest (a -> b) -> Coforest b
        interleaveFs []       = interleaveAs as
        interleaveFs (h :: t) = interleave h ta :: interleaveFs t

public export
bind : Cotree a -> (a -> Cotree b) -> Cotree b
bind (MkCotree v vs) f = let MkCotree w ws = f v
                       in MkCotree w (run vs ws)
  where run : Coforest a -> Coforest b -> Coforest b
        run []        ys = ys
        run (x :: xs) ys = bind x f :: run xs ys

public export
bindMaybe : Cotree (Maybe a) -> (a -> Cotree (Maybe b)) -> Cotree (Maybe b)
bindMaybe (MkCotree mv tas) f =
  case map f mv of
       Nothing => MkCotree Nothing (run tas Nil)
       Just (MkCotree mb tbs) => MkCotree mb (run tas tbs)

  where run : Coforest (Maybe a) -> Coforest (Maybe b) -> Coforest (Maybe b)
        run [] ys        = ys
        run (x :: xs) ys = bindMaybe x f :: run xs ys

--------------------------------------------------------------------------------
--          Shrinking
--------------------------------------------------------------------------------

public export
shrink : (maxSteps : Nat) -> Cotree (Maybe a) -> List a
shrink maxSteps x = run maxSteps [x]
  where run : Nat -> Coforest (Maybe a) -> List a
        run _ Nil          = Nil
        run 0 _            = Nil
        run (S k) (h :: t) = case h.value of
                               Just a  => a :: run k h.forest
                               Nothing => run k t

public export
mapShrink : (maxSteps : Nat) -> (a -> Maybe b) -> Cotree a -> List b
mapShrink ms f = shrink ms . mapCotree f

public export
shrinkIf : (maxSteps : Nat) -> (a -> Bool) -> Cotree a -> List a
shrinkIf ms p = mapShrink ms (\a => if p a then Just a else Nothing)

||| Prunes a cotree up to the given depth and width.
public export
pruneTo : (width : Nat) -> (depth : Nat) -> Cotree a -> Cotree a
pruneTo _ 0     (MkCotree v _ ) = MkCotree v Nil
pruneTo w (S d) (MkCotree v vs) = MkCotree v $ (map (pruneTo w d) $ keep w vs)
  where keep : Nat -> Colist t -> Colist t
        keep _ [] = []
        keep 0 _  = []
        keep (S k) (x :: xs) = x :: keep k xs

||| Removes all children from a cotree
public export
prune : Cotree a -> Cotree a
prune = pruneTo 0 0

--------------------------------------------------------------------------------
--          Interfaces
--------------------------------------------------------------------------------

public export
Functor Cotree where
  map = mapCotree

public export
Applicative Cotree where
  pure  = singleton
  (<*>) = interleave

--------------------------------------------------------------------------------
--          Filtering
--------------------------------------------------------------------------------

public export
takeUntil : (a -> Bool) -> Cotree a -> Cotree a
takeUntil f (MkCotree v vs) = if f v then MkCotree v []
                                     else MkCotree v (takeUntilF vs)
  where takeUntilF : Coforest a -> Coforest a
        takeUntilF []        = vs
        takeUntilF (MkCotree x xs :: ts) =
          if f x
             then [MkCotree x []]
             else MkCotree x (takeUntilF xs) :: takeUntilF ts

public export
takeBeforeNothing : Cotree (Maybe a) -> Maybe (Cotree a)
takeBeforeNothing (MkCotree Nothing _) = Nothing
takeBeforeNothing (MkCotree (Just v) vs) = Just (MkCotree v (run vs))
  where run : Coforest (Maybe a) -> Coforest a
        run []                             = []
        run ((MkCotree Nothing _) :: _)    = []
        run ((MkCotree (Just v) vs) :: ts) = MkCotree v (run vs) :: run ts

public export
takeBefore : (a -> Bool) -> Cotree a -> Maybe (Cotree a)
takeBefore f = takeBeforeNothing . map (\a => toMaybe (f a) a)

public export %inline
takeWhile : (a -> Bool) -> Cotree a -> Maybe (Cotree a)
takeWhile f = takeBefore (not . f)

public export %inline
mapMaybe : (a -> Maybe b) -> Cotree a -> Maybe (Cotree b)
mapMaybe f = takeBeforeNothing . map f


module Stack

import Data.Vect

data StackCmd : Type -> Nat -> Nat -> Type where
  Push: Integer -> StackCmd () hieght (S hieght)
  Pop: StackCmd Integer (S hieght) hieght
  Top: StackCmd Integer (S hieght) (S hieght)

  Pure: Integer -> StackCmd Integer state state
  (>>=): StackCmd a state1 state2 -> (a -> StackCmd Integer state2 state3) -> StackCmd Integer state1 state3

testAdd : StackCmd Integer 0 0
testAdd = do Push 10
             Push 20
             val1 <- Pop
             val2 <- Pop
             Pure (val1 + val2)

runStack : (stack: Vect inH Integer) -> StackCmd ty inH outH -> (ty, Vect outH Integer)
runStack stack (Push x) = ((), x::stack)
runStack (val::xs) Pop = (val, xs)
runStack (val::xs) Top = (val, val::xs)

runStack stack (Pure x) = (x, stack)
runStack stack (x >>= f) = let (res, newStack) = runStack stack x
  in runStack newStack (f res)

readVectLen: Vect n String
readVectLen = ["test", "twenty"]


module Data.Hashable

import Data.Vect

||| A default salt used in the implementation of 'hash'.
export
defaultSalt : Bits64
defaultSalt = 14695981039346656037

infixl 10 `hashWithSalt`
infixl 10 `hash`

||| Interface for type that can be hashed.
||| Minimal implementation: 'hashWithSalt'
public export
interface Hashable a where
    ||| Hash a value with the given salt
    total
    hashWithSalt : Bits64 -> a -> Bits64
    ||| Hash a value with the default salt
    total
    hash : a -> Bits64
    hash = hashWithSalt defaultSalt

||| Combine 2 hashes.
export
combine : Bits64 -> Bits64 -> Bits64
combine h1 h2 = (h1 * 16777619) `prim__xor_Bits64` h2

||| Default implementation of 'hashWithSalt' for types which are smaller than Bits64 (eg Bits32, Int).
export
defaultHashWithSalt : (a -> Bits64) -> Bits64 -> a -> Bits64
defaultHashWithSalt hash salt x = salt `combine` hash x

export
Hashable Bits8 where
    hash = cast
    hashWithSalt = defaultHashWithSalt hash

export
Hashable Bits16 where
    hash = cast
    hashWithSalt = defaultHashWithSalt hash

export
Hashable Bits32 where
    hash = cast
    hashWithSalt = defaultHashWithSalt hash

export
Hashable Bits64 where
    hash = id
    hashWithSalt = defaultHashWithSalt hash

export
Hashable Int where
    hash = cast
    hashWithSalt = defaultHashWithSalt hash

export
Hashable Int8 where
    hash = cast
    hashWithSalt = defaultHashWithSalt hash

export
Hashable Int16 where
    hash = cast
    hashWithSalt = defaultHashWithSalt hash

export
Hashable Int32 where
    hash = cast
    hashWithSalt = defaultHashWithSalt hash

export
Hashable Int64 where
    hash = cast
    hashWithSalt = defaultHashWithSalt hash

export
Hashable Char where
    hash = cast . ord
    hashWithSalt = defaultHashWithSalt hash

export
Hashable Integer where
    hashWithSalt salt x = hashPositive (makeSalt salt x) (abs x)
      where
        makeSalt : Bits64 -> Integer -> Bits64
        makeSalt x y = if y >= 0
            then x
            else negate x

        bits64Max : Integer
        bits64Max = 1 `prim__shl_Integer` 64 - 1

        hashPositive : Bits64 -> Integer -> Bits64
        hashPositive salt x = if x > bits64Max
            then hashPositive
                (hashWithSalt salt
                    (cast {to=Bits64} (x `prim__and_Integer` bits64Max)))
                (assert_smaller x $ x `prim__shr_Integer` 64)
            else hashWithSalt salt (cast {to=Bits64} x)

export
Hashable Nat where
    hash x = hash (cast {to=Integer} x)
    hashWithSalt salt x = hashWithSalt salt (cast {to=Integer} x)

export
Hashable String where
    hashWithSalt salt str = finalise (foldl step (salt, 0) $ fastUnpack str)
      where
        step : (Bits64, Bits64) -> Char -> (Bits64, Bits64)
        step (s, l) x = (hashWithSalt s x, l + 1)
        finalise : (Bits64, Bits64) -> Bits64
        finalise (s, l) = hashWithSalt s l

export
Hashable Bool where
    hash False = 0
    hash True = 1

    hashWithSalt = defaultHashWithSalt hash

export
Hashable a => Hashable (Maybe a) where
    hashWithSalt salt Nothing = hashWithSalt salt 0
    hashWithSalt salt (Just x) = hashWithSalt salt 1 `hashWithSalt` x

export
Hashable a => Hashable (List a) where
    hashWithSalt salt [] = hashWithSalt salt 0
    hashWithSalt salt (x :: xs) =
        salt
            `hashWithSalt` 1
            `hashWithSalt` x
            `hashWithSalt` xs

export
Hashable a => Hashable (SnocList a) where
    hashWithSalt salt [<] = hashWithSalt salt 0
    hashWithSalt salt (sx :< x) =
        salt
            `hashWithSalt` 1
            `hashWithSalt` x
            `hashWithSalt` sx

export
Hashable a => Hashable (Vect len a) where
    hashWithSalt salt [] = hashWithSalt salt 0
    hashWithSalt salt (x :: xs) =
        salt
            `hashWithSalt` 1
            `hashWithSalt` x
            `hashWithSalt` xs


module Test.String

import Data.Prim.String
import Data.SOP
import Hedgehog

allString : Gen String
allString = string (linear 0 30) unicodeAll

prop_ltMin : Property
prop_ltMin = property $ do
  b8 <- forAll allString
  (b8 >= MinString) === True

prop_comp : Property
prop_comp = property $ do
  [m,n] <- forAll $ np [allString, allString]
  toOrdering (comp m n) === compare m n

export
props : Group
props = MkGroup "String"
  [ ("prop_ltMin",  prop_ltMin)
  , ("prop_comp",   prop_comp)
  ]


module CH06.DataStore

import Data.Vect

infixr 5 .+.

data Schema = SString
            | SInt
            | SChar
            | (.+.) Schema Schema

SchemaType : Schema -> Type
SchemaType SString   = String
SchemaType SInt      = Int
SchemaType SChar     = Char
SchemaType (x .+. y) = (SchemaType x, SchemaType y)

data DataStore : Type where
  MkData : (schema : Schema)
         -> (size : Nat)
         -> (items : Vect size (SchemaType schema))
         -> DataStore

data Command : Schema -> Type where
  SetSchema : (newschema : Schema)  -> Command schema
  Add  : SchemaType schema -> Command schema
  Get  : Integer -> Command schema
  Size : Command schema
  Quit : Command schema

display : SchemaType schema -> String
display {schema = SString} item             = item
display {schema = SInt} item                = show item
display {schema = SChar} item               = show item
display {schema = (x .+. y)} (iteml, itemr) = display iteml ++ ", " ++ display itemr

parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)
parsePrefix SChar input                 = case unpack input of
                                            [x]              => Just (x, "")
                                            (x :: ' ' :: xs) => Just (x, ltrim $ pack xs)
                                            _                => Nothing
parsePrefix SString input               = getQuoted (unpack input)
  where
    getQuoted : List Char -> Maybe (String, String)
    getQuoted ('"' :: xs) =
      case span (/= '"') xs of
        (quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest))
        _                     => Nothing
    getQuoted _           = Nothing
parsePrefix SInt input                  = case span isDigit input of
                                          ("", _)     => Nothing
                                          (num, rest) => Just (cast num, ltrim rest)
parsePrefix (schemal .+. schemar) input = do
  (lval, inputl) <- parsePrefix schemal input
  (rval, inputr) <- parsePrefix schemar inputl
  pure ((lval, rval), inputr)

parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)
parseBySchema schema input =
  case parsePrefix schema input of
    Just (res, "") => Just res
    _              => Nothing

size : DataStore -> Nat
size (MkData schema' size' items') = size'

schema : DataStore -> Schema
schema (MkData schema' size' items') = schema'

items : (store : DataStore) -> Vect (size store) (SchemaType (schema store))
items (MkData schema' size' items') = items'

addToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore
addToStore (MkData schema' size' store') newitem = MkData schema' _ (addToData store')
  where
    addToData : Vect oldSize (SchemaType schema') -> Vect (S oldSize) (SchemaType schema')
    addToData []        = [newitem]
    addToData (x :: xs) = x :: addToData xs

setSchema : (store : DataStore) -> Schema -> Maybe DataStore
setSchema store schema = case size store of
                           Z => Just (MkData schema _ [])
                           _ => Nothing

parseSchema : List String -> Maybe Schema
parseSchema ("String" :: xs) =
  case xs of
    [] => Just SString
    _  => do
      schema1 <- parseSchema xs
      Just (SString .+. schema1)
parseSchema ("Char" :: xs)   =
  case xs of
    [] => Just SChar
    _  => do
      schema1 <- parseSchema xs
      Just (SChar .+. schema1)
parseSchema ("Int" :: xs)    =
  case xs of
    [] => Just SInt
    _  => do
      schema1 <- parseSchema xs
      Just (SInt .+. schema1)
parseSchema _                = Nothing

parseCommand : (schema : Schema) -> (cmd : String) -> (args : String) -> Maybe (Command schema)
parseCommand schema "schema" rest = SetSchema <$> (parseSchema (words rest))
parseCommand schema "add" val     = Add <$> (parseBySchema schema val)
parseCommand schema "get" val     = if all isDigit (unpack val)
                                    then Nothing
                                    else Just (Get (cast val))
parseCommand schema "quit" ""     = Just Quit
parseCommand schema "size" ""     = Just Size
parseCommand _ _ _                = Nothing

parse : (schema : Schema) -> (input : String) -> Maybe (Command schema)
parse schema input = case span (/= ' ') input of
                       (cmd, args) => parseCommand schema cmd (ltrim args)

getEntry : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore)
getEntry pos store = let store_items = items store
                     in case integerToFin pos (size store) of
                          Nothing => Just ("Out of range\n", store)
                          Just id => Just ((display $ index id store_items) ++ "\n", store)

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input =
  case parse (schema store) input of
    Nothing                  => Just ("Invalid command\n", store)
    Just (SetSchema schema') => case setSchema store schema' of
                                  Nothing     => Just ("Can't update scema\n", store)
                                  Just store' => Just ("OK\n", store')
    Just (Add item)          => Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
    Just (Get pos)           => getEntry pos store
    Just Size                => Just("Size " ++ show (size store) ++ "\n", store)
    Just Quit                => Nothing

main : IO ()
main = replWith (MkData (SString .+. SString .+. SInt) _ []) "Command: " processInput


module Minecraft.Data.Type.As

import public Minecraft.Data.Type.Ctx
import public Minecraft.Data.Type.Vtbl

%default total

public export
record As kind where
  constructor New
  ctx : Ctx kind
  val : ctx.type
  {auto vtbl : Vtbl ctx.type}

export
new : {kind : Type -> Type} -> (type : Type) -> (val : type) -> (impl : kind type) => (vtbl : Vtbl type) => As kind
new {kind} type val @{impl} @{vtbl} = New ((#) type @{impl}) val @{vtbl}

export
app : forall r. {kind : Type -> Type} -> (x : As kind) -> (f : kind x.ctx.type => x.ctx.type -> r) -> r
app {kind} x f = f @{x.ctx.impl} x.val

export
cast : (kind : Type -> Type) -> As _ -> Maybe (As kind)
cast kind (New ctx val {vtbl}) = case vtable @{vtbl} (kind ctx.type) of
  Just impl => Just (New ((#) ctx.type {impl}) val @{vtbl})
  Nothing => Nothing

export
castApp : forall r. (kind : Type -> Type) -> (x : As _) -> (f : kind x.ctx.type => x.ctx.type -> r) -> Maybe r
castApp kind  (New ctx val {vtbl}) f = case vtable @{vtbl} (kind ctx.type) of
  Just impl => Just (f @{impl} val)
  Nothing => Nothing


||| Data type `Validated` was introduced in chapter
||| *Functor and Friends*. It provides an error type
||| with the ability of error accumulation.
module Data.Validated

%default total

public export
data Validated : (e,a : Type) -> Type where
  Invalid : (err : e) -> Validated e a
  Valid   : (val : a) -> Validated e a

--------------------------------------------------------------------------------
--          Utilities
--------------------------------------------------------------------------------

public export
validated : (e -> b) -> (a -> b) -> Validated e a -> b
validated f _ (Invalid ve) = f ve
validated _ g (Valid va)   = g va

public export
fromEither : Either e a -> Validated e a
fromEither = either Invalid Valid

public export
toEither : Validated e a -> Either e a
toEither = validated Left Right

--------------------------------------------------------------------------------
--          Interfaces
--------------------------------------------------------------------------------

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

public export
Ord e => Ord a => Ord (Validated e a) where
  compare (Invalid x) (Invalid y) = compare x y
  compare (Invalid _) (Valid _)   = LT
  compare (Valid _)   (Invalid _) = GT
  compare (Valid x)   (Valid y)   = compare x y

public export
Show e => Show a => Show (Validated e a) where
  showPrec p (Invalid e) = showCon p "Invalid" (showArg e)
  showPrec p (Valid a)   = showCon p "Valid" (showArg a)

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

public export
Semigroup e => Applicative (Validated e) where
  pure = Valid
  Valid   f  <*> Valid v    = Valid $ f v
  Valid   _  <*> Invalid ve = Invalid ve
  Invalid e1 <*> Invalid e2 = Invalid $ e1 <+> e2
  Invalid ve <*> Valid _    = Invalid ve

public export
Foldable (Validated e) where
  foldr acc st (Invalid _) = st
  foldr acc st (Valid v)   = acc v st

  foldl acc st (Invalid _) = st
  foldl acc st (Valid v)   = acc st v

  foldlM acc st (Invalid _) = pure st
  foldlM acc st (Valid v)   = acc st v

  foldMap f (Invalid _) = neutral
  foldMap f (Valid v)   = f v

  toList (Invalid _) = []
  toList (Valid v)   = [v]

  null (Invalid _) = True
  null (Valid v)   = False

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

public export
Bifunctor Validated where
  bimap f g (Invalid ve) = Invalid $ f ve
  bimap f g (Valid va)   = Valid $ g va

  mapFst f (Invalid ve) = Invalid $ f ve
  mapFst f (Valid va)   = Valid va

  mapSnd f (Invalid ve) = Invalid ve
  mapSnd f (Valid va)   = Valid $ f va

public export
Bifoldable Validated where
  bifoldr f g st (Invalid ve) = f ve st
  bifoldr f g st (Valid va)   = g va st

  bifoldl f g st (Invalid ve) = f st ve
  bifoldl f g st (Valid va)   = g st va

  binull _ = False

public export
Bitraversable Validated where
  bitraverse f g (Invalid ve) = Invalid <$> f ve
  bitraverse f g (Valid va)   = Valid <$> g va

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

  Valid va  <|> _         = Valid va
  Invalid x <|> Invalid y = Invalid $ x <+> y
  Invalid _ <|> Valid va  = Valid va


module Compile

import Syntax
import Machine

export
compile : Expr -> List Instr
compile (Var nm) = [IVar nm]
compile (EInt i) = [IInt i]
compile (EBool b) = [IBool b]
compile (Times e1 e2) = compile e1 ++ compile e2 ++ [IMult]
compile (Plus e1 e2) = compile e1 ++ compile e2 ++ [IAdd]
compile (Minus e1 e2) = compile e1 ++ compile e2 ++ [ISub]
compile (Equal e1 e2) = compile e1 ++ compile e2 ++ [IEqual]
compile (Less e1 e2) = compile e1 ++ compile e2 ++ [ILess]
compile (If e1 e2 e3) = compile e1 ++ [IBranch (compile e2) (compile e3)]
compile (Fun fnm nm _ _ body) = [IClosure fnm nm (compile body ++ [IPopEnv])]
compile (Apply e1 e2) = (compile e1) ++ (compile e2) ++ [ICall]