module Data.List.Predicates.Unique

import public Data.List.NotElem

%default total
%access public export

data Unique : (prfSame : a -> a -> Type)
            -> (ns : List a)
            -> Type
  where
    Empty : Unique p Nil
    Extend : (node : a)
          -> (prfNotElem : NotElem p node ns)
          -> (rest : Unique p ns)
          -> Unique p (node :: ns)

nodeIsFoundLater : (contra : NotElem prfSame x xs -> Void)
                -> Unique prfSame (x :: xs)
                -> Void
nodeIsFoundLater contra (Extend x prfNotElem rest) = contra prfNotElem

restNotUnique : (contra : Unique prfSame xs -> Void)
             -> (prfX : NotElem prfSame x xs)
             -> Unique prfSame (x :: xs)
             -> Void
restNotUnique contra prfX (Extend x prfNotElem rest) = contra rest

unique : (decEq : (x,y : a) -> Dec (prfSame x y))
     -> (xs    : List a)
     -> Dec (Unique prfSame xs)
unique decEq [] = Yes Empty
unique decEq (x :: xs) with (notElem decEq x xs)
  unique decEq (x :: xs) | (Yes prfX) with (unique decEq xs)
    unique decEq (x :: xs) | (Yes prfX) | (Yes prfXS) = Yes (Extend x prfX prfXS)
    unique decEq (x :: xs) | (Yes prfX) | (No contra) = No (restNotUnique contra prfX)

  unique decEq (x :: xs) | (No contra) = No (nodeIsFoundLater contra)

toList : {ns : List a} -> Unique prfSame ns -> List a
toList Empty = []
toList (Extend node prfNotElem rest) = node :: toList rest

-- --------------------------------------------------------------------- [ EOF ]


> module Subset.Operations

> import Data.Fin
> import Data.Vect
> import Control.Isomorphism

> import Sigma.Sigma
> import Pairs.Operations
> import Finite.Predicates
> import Decidable.Predicates
> import Finite.Operations
> import Vect.Operations

> %default total

> %access public export

> |||
> outl : {A : Type} -> {P : A -> Type} -> Subset A P -> A
> outl = getWitness

> |||
> outr : {A : Type} -> {P : A -> Type} -> (s : Subset A P) -> P (outl s)
> outr = getProof

> ||| Maps a finite type |A| and a decidable predicate |P| to a vector |Subset A P| values
> toVectSubset : {A : Type} ->
>                {P : A -> Type} ->
>                Finite A ->
>                Dec1 P ->
>                Sigma Nat (\ n => Vect n (Subset A P))
> toVectSubset fA d1P = filterTagSubset d1P (toVect fA)


module Progress

-- Progress theorem for the 'Step' relation.

import Step
import Subst
import Term

%default total
%access export

-------------------------------------
-- Begin: PROGRESS (AND PRESERVATION)

-- Function 'progress' proves the usual progress lemma.
--
-- Progress: a closed, well-typed term is either a value
--           or it can take a step in the reduction relation.
--
-- Preservation: after reducing a term of type 't' by one
--               step, the resulting term is again of type 't'.
--
--   ***  Note that preservation is already built into     ***
--   ***  the relation 'Step' as defined in module "Step". ***
--
progress : (e : Term [] t) -> Either (Value e) (e' : Term [] t ** (Step e e'))
-- Expressions that are variables cannot occur in an empty context:
-- (In other words, variables are not closed expressions.)
progress (TVar _) impossible
-- Abstractions are values already:
progress (TAbs _) = Left VAbs
-- Applications can reduce in three different ways, the most
-- interesting of which occurs when both arguments of 'App'
-- are values already: in this case, the function 'subst'
-- is required:
progress (TApp e1 e2) = case progress e1 of
  Right (e' ** st) => Right (TApp e' e2 ** StApp1 st)
  Left  v1         =>
    case progress e2 of
         Right (e' ** st) => Right (TApp e1 e' ** StApp2 v1 st)
         Left  v2         => case e1 of
                                  TAbs f => let e'' = subst e2 First f
                                            in Right (e'' ** StBeta v2)
-- When the fix-point operator is applied to a value,
-- that value is necessarily an abstraction; hence
-- the function 'subst' is used in reducing 'Fix _':
progress (TFix e) = case progress e of
  Right (e' ** st) => Right (TFix e' ** StFix st)
  Left v           =>
    case e of
         TAbs f => let e'' = subst (TFix (TAbs f)) First f
                   in Right (e'' ** StFixBeta)
-- The constant 'Zero' is a value already:
progress TZero = Left VZero
--
progress (TSucc e) = case progress e of
  Right (e' ** st) => Right (TSucc e' ** StSucc st)
  Left  v          => Left (VSucc v)
progress (TPred e) = case progress e of
  Right (e' ** st) => Right (TPred e' ** StPred st)
  Left v           =>
    case e of
         TZero    => Right (TZero ** StPredZero)
         TSucc e' => case v of
                          VAbs     impossible
                          VZero    impossible
                          VSucc v' => Right (e' ** StPredSucc v')
--
progress (TIfz e1 e2 e3) = case progress e1 of
  Right (e' ** st) => Right $ (TIfz e' e2 e3 ** StIfz st)
  Left v           => case v of
                           VAbs     impossible
                           VZero    => Right (e2 ** StIfzZero)
                           VSucc v' => Right (e3 ** StIfzSucc v')

-- End: PROGRESS (AND PRESERVATION)
-----------------------------------

-------------------------------
-- Begin: VALUE <=> IRREDUCIBLE

-- Establish that values cannot be further reduced under 'Step'.
valueIrreducible : (e : Term [] t) ->
                   Value e ->
                   {e' : Term [] t} -> Step e e' -> Void
valueIrreducible TZero     VZero     _           impossible
valueIrreducible (TSucc n) (VSucc v) (StSucc st) = valueIrreducible n v st
valueIrreducible (TAbs _)  VAbs      _           impossible

-- Establish that irreducible expressions (under 'Step') are values:
irreducibleValue : (e : Term [] t) ->
                   ({e' : Term [] t} -> Step e e' -> Void) ->
                   Value e
irreducibleValue e notStep = case progress e of
  Right (_ ** st) => absurd $ notStep st
  Left v          => v

coTransStepValueIrreducible : CoTransStep e1 e2 -> Value e1 -> e1 = e2
coTransStepValueIrreducible (CoTStRefl e1)       v = Refl
coTransStepValueIrreducible (CoTStTrans st ctst) v = absurd $ valueIrreducible _ v st

-- End: VALUE <=> IRREDUCIBLE
-----------------------------


module Instances.TrustInteger

import Common.Util
import Common.Interfaces
import Specifications.DiscreteOrderedGroup
import Specifications.OrderedRing
import Instances.Notation

%default total
%access public export

data IntegerLeq : Integer -> Integer -> Type where
  CheckIntegerLeq : So (intToBool (prim__slteBigInt a b)) -> IntegerLeq a b

soIntegerLeq : IntegerLeq a b -> So (intToBool (prim__slteBigInt a b))
soIntegerLeq (CheckIntegerLeq so) = so

decideLeq : (a,b : Integer) -> Dec (IntegerLeq a b)
decideLeq a b = case isItSo (intToBool (prim__slteBigInt a b)) of
  Yes oh => Yes (CheckIntegerLeq oh)
  No contra => No (contra . soIntegerLeq)

implementation Ringops Integer where Ng = negate

implementation Decidable [Integer, Integer] IntegerLeq where
  decide = decideLeq

postulate integerDiscreteOrderedRing :
  specifyDiscreteOrderedRing {leq = IntegerLeq}

integerDiscreteOrderedGroup : specifyDiscreteOrderedGroup {leq = IntegerLeq}
integerDiscreteOrderedGroup = discreteOrderedGroup integerDiscreteOrderedRing

integerPartiallyOrderedGroup : specifyPartiallyOrderedGroup {leq = IntegerLeq}
integerPartiallyOrderedGroup = partiallyOrderedGroup integerDiscreteOrderedGroup


module Main

import Data.String
import Data.List

maxByThird : Ord c => List (a, b, c) -> (a, b, c)
maxByThird = foldr1 (\(ax, ay, av), (x, y, v) => if v > av then (x, y, v) else (ax, ay, av))

cell : Integer -> Integer -> Integer -> Integer
cell x y serial = (mod (div ((((x + 10) * y) + serial) * (x + 10)) 100) 10) - 5

grid : Integer -> List (List Integer)
grid serial = [[cell x y serial | y <- [1..300]] | x <- [1..300]]

squareCell : Integer -> Integer -> Integer -> List (List Integer) -> Integer
squareCell size x y g = if (x + size - 1) > 300 || (y + size - 1) > 300 then 0 else
    sum
    . map (
        sum
        . List.take (fromIntegerNat size)
        . List.drop (fromIntegerNat (y - 1))
        )
    . List.take (fromIntegerNat size)
    . List.drop (fromIntegerNat (x - 1))
    $ g

square : Integer -> List (List Integer) -> (Integer, Integer, Integer)
square size g = maxByThird [(x, y, squareCell size x y g) | x <- [1..300 - (size - 2)], y <- [1..300 - (size - 2)]]

part1 : List (List Integer) -> (Integer, Integer, Integer)
part1 = square 3

part2 : List (List Integer) -> (Integer, Integer, Integer)
part2 g = maxByThird [square size g | size <- [1..10]]

main : IO()
main = do
    (Right str) <- readFile "11.in"
    let (Just serial) = String.parseInteger str
    let g = grid serial
    putStrLn "(x, (y, power)"
    printLn $ square 1 g
    printLn $ square 2 g
    putStrLn "Solution for part 1:"
    printLn $ square 3 g
    printLn $ square 4 g
    printLn $ square 5 g
    printLn $ square 6 g
    printLn $ square 7 g
    printLn $ square 8 g
    printLn $ square 9 g
    printLn $ square 10 g
    printLn $ square 11 g
    printLn $ square 12 g
    printLn $ square 13 g
    printLn $ square 14 g
    printLn $ square 15 g
    printLn $ square 16 g
    printLn $ square 17 g
    printLn $ square 18 g
    printLn $ square 19 g
    printLn $ square 20 g
    printLn $ square 21 g
    printLn $ square 22 g
    printLn $ square 23 g
    printLn $ square 24 g
    printLn $ square 25 g
    printLn $ square 26 g
    printLn $ square 27 g
    printLn $ square 28 g
    printLn $ square 29 g

    -- I do not want to optimize this right now, so... it works so it's good.
    -- You just take the biggest power, seems to be between 13 and 20 all the time.
    -- Starts at one, the size is the line number, not counting the info lines.

-- Solution part 1: 235,87
-- Solution part 2: 234,272,18


data ListLast : List a -> Type where
    Empty : ListLast []
    NonEmpty : (xs : List a) -> (x : a) -> ListLast (xs ++ [x])

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

total
listLast : (xs : List a) -> ListLast xs
listLast [] = Empty
listLast (x :: xs) =
    case listLast xs of
        Empty => NonEmpty [] x
        NonEmpty ys y => NonEmpty (x :: ys) y

descibeListEnd : Show a => List a -> String
descibeListEnd xs = describeHelper xs (listLast xs)

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

myReverse : List a -> List a
myReverse input with (listLast input)
  myReverse [] | Empty = []
  myReverse (xs ++ [x]) | (NonEmpty xs x) = x :: myReverse xs


import Aoc
import Data.Nat
import Data.Strings

Point : Type
Point = (Integer, Integer)

||| Add two points.
(+~) : Point -> Point -> Point
(+~) (x,y) (x',y') = (x+x',y+y')
infixl 5 +~

||| Scale a point.
(*~) : Integer -> Point -> Point
(*~) n (x,y) = (n*x,n*y)
infixl 6 *~

||| Turn a vector 90° to the left. (+x is >, +y is ^)
turnLeft : Point -> Point
turnLeft (x,y) = (-y,x)

||| Turn a vector 90° to the right. (+x is >, +y is ^)
turnRight : Point -> Point
turnRight (x,y) = (y,-x)

manhattanNorm : Point -> Integer
manhattanNorm (x,y) = abs x + abs y

record Ship where
  constructor MkShip
  position : Point
  direction : Point

data Instruction
  = North Integer
  | South Integer
  | East Integer
  | West Integer
  | Left90 Nat
  | Right90 Nat
  | Forward Integer

||| Move a ship's position.
move : Point -> Ship -> Ship
move d s = record { position $= (+~ d) } s

||| Move a ship's waypoint (direction vector).
moveWaypoint : Point -> Ship -> Ship
moveWaypoint d s = record { direction $= (+~ d) } s

||| Follow an instruction, * style.
step1 : Ship -> Instruction -> Ship
step1 s (North n) = move (0, n) s
step1 s (South n) = move (0, -n) s
step1 s (East n) = move (n, 0) s
step1 s (West n) = move (-n, 0) s
step1 s (Left90 n) = record { direction $= times n turnLeft } s
step1 s (Right90 n) = record { direction $= times n turnRight } s
step1 s (Forward n) = move (n *~ s.direction) s

||| Follow an instruction, ** style.
step2 : Ship -> Instruction -> Ship
step2 s (North n) = moveWaypoint (0, n) s
step2 s (South n) = moveWaypoint (0, -n) s
step2 s (East n) = moveWaypoint (n, 0) s
step2 s (West n) = moveWaypoint (-n, 0) s
step2 s (Left90 n) = record { direction $= times n turnLeft } s
step2 s (Right90 n) = record { direction $= times n turnRight } s
step2 s (Forward n) = move (n *~ s.direction) s

||| Try to divide a natural number by 90.
div90 : Nat -> Maybe Nat
div90 n =
  case divmodNatNZ n 90 SIsNotZ of
    (k, 0) => Just k
    _ => Nothing

||| Try to parse an instruciton.
parseInstruction : String -> Maybe Instruction
parseInstruction s =
  case break isDigit s of
    ("N", n) => North <$> parsePositive n
    ("S", n) => South <$> parsePositive n
    ("E", n) => East <$> parsePositive n
    ("W", n) => West <$> parsePositive n
    ("L", n) => Left90 <$> (parsePositive n >>= div90)
    ("R", n) => Right90 <$> (parsePositive n >>= div90)
    ("F", n) => Forward <$> parsePositive n
    _ => Nothing

main : IO ()
main = do
  xs <- parseLines parseInstruction
  let ship1 = foldl step1 (MkShip (0, 0) (1, 0)) xs
  putStr "*   "; printLn (manhattanNorm ship1.position)
  let ship2 = foldl step2 (MkShip (0, 0) (10, 1)) xs
  putStr "**  "; printLn (manhattanNorm ship2.position)


module Data.AVL.Core.Quantifiers

import public Data.Tree
import public Data.AVL.Core
import public Data.AVL.Core.API

%default total
%access export

namespace AVL
  namespace Keys

    public export
    data HasKey : (key : typeKey)
               -> (tree : AVLTree h typeKey typeValue)
               -> Type
      where
        IsKey : (prf : IsKeyIn key (Subset.getWitness avl))
             -> HasKey key avl

    keyNotInAVlTree : (contra : IsKeyIn key tree -> Void)
                   -> HasKey key (Element tree prf)
                   -> Void
    keyNotInAVlTree contra (IsKey x) = contra x

    isKey : DecEq typeKey
         => (key : typeKey)
         -> (tree : AVLTree h typeKey typeValue)
         -> Dec (HasKey key tree)
    isKey key (Element tree prf) with (isKey key tree)
      isKey key (Element tree prf) | (Yes x) = Yes (IsKey x)
      isKey key (Element tree prf) | (No contra) = No (keyNotInAVlTree contra)

    public export
    data All : (predicate : typeKey -> Type)
            -> (tree : AVLTree h typeKey typeValue)
            -> Type
      where
        MkProof : (prf : Tree.Keys.All p (Subset.getWitness avl))
               -> All p avl

  namespace Values

    public export
    data HasValue : (value : typeValue)
                 -> (tree : AVLTree h typeKey typeValue)
                 -> Type
      where
        IsValue : (prf : IsValueIn value (Subset.getWitness avl))
               -> HasValue value avl

    valueNotInAVLTree : (contra : IsValueIn value tree -> Void)
                     -> HasValue value (Element tree prf)
                     -> Void
    valueNotInAVLTree contra (IsValue prf) = contra prf

    isValue : DecEq typeValue
           => (value : typeValue)
           -> (tree : AVLTree h typeKey typeValue)
           -> Dec (HasValue value tree)
    isValue value (Element tree prf) with (isValue value tree)
      isValue value (Element tree prf) | (Yes x) = Yes (IsValue x)
      isValue value (Element tree prf) | (No contra) = No (valueNotInAVLTree contra)

    public export
    data All : (predicate : typeValue -> Type)
            -> (tree : AVLTree h typeKey typeValue)
            -> Type
      where
        MkProof : (prf : Tree.Values.All p (Subset.getWitness avl))
               -> AVL.Values.All p avl

  namespace KVPairs

    public export
    data All : (predicate : typeKey -> typeValue -> Type)
            -> (tree : AVLTree k typeKey typeValue)
            -> Type
      where
        MkProof : (prf : Tree.KVPairs.All p (Subset.getWitness avl))
                -> All p avl


module Sub01Apply18x3

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqPostuProof

%default total
-- %language ElabReflection

-- 3(6x+1) --B[1,-2]--> 3x
export
apply18x3 : (Not . P) (S (plus (plus (plus k k) (plus k k)) (plus k k)))
  -> (m : Nat **
      (LTE (S m) (S (plus (plus (plus k k) (plus k k)) (plus k k))), (Not . P) m))
apply18x3 {k} col = (k ** (lte18x3 k, b18x3To3x k col)) where
  lte18x3 : (k:Nat) -> LTE (S k) (S (plus (plus (plus k k) (plus k k)) (plus k k)))
  lte18x3 Z = LTESucc LTEZero
  lte18x3 (S k) = rewrite (sym (plusSuccRightSucc k k)) in
    rewrite (sym (plusSuccRightSucc (plus k k) (S (plus k k)))) in
    rewrite (sym (plusSuccRightSucc (plus k k) (plus k k))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) (plus k k)) (S (plus k k)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) (plus k k)) (plus k k))) in
      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc) (lte18x3 k)


module BigStep

-- Relation 'BigStep' for fully reducing terms
-- in the simply-typed lambda calculus to values.

import Term
import Subst

%default total
%access public export

-----------------------------------------------------------------------
-- Begin: BIG-STEP EVALUATION RELATION FOR TERMS IN THE LAMBDA CALCULUS

-- The relation 'BigStep' defines evaluation of terms in the lambda
-- calculus following big-step semantics.
--
-- Big-step semantics fully evaluates terms to values.
-- (A proof of this statement appears below.)
data BigStep : Term [] t -> (y: Term [] t) -> Type where
  BStValue    : (v : Value e) -> BigStep e e
  --
  BStApp      : BigStep e1 (TAbs e1') ->
                BigStep e2 e2' ->
                BigStep (subst e2' First e1') e ->
                BigStep (TApp e1 e2) e
  --
  BStFix      : BigStep e (TAbs e') ->
                BigStep (subst (TFix (TAbs e')) First e') e'' ->
                BigStep (TFix e) e''
  --
  BStSucc     : BigStep e e' ->
                BigStep (TSucc e) (TSucc e')
  --
  BStPredZero : BigStep e TZero ->
                BigStep (TPred e) TZero
  --
  BStPredSucc : BigStep e (TSucc e') ->
                BigStep (TPred e) e'
  --
  BStIfzZero  : BigStep e1 TZero ->
                BigStep e2 e ->
                BigStep (TIfz e1 e2 _) e
  --
  BStIfzSucc  : BigStep e1 (TSucc _) ->
                BigStep e3 e ->
                BigStep (TIfz e1 _ e3) e

bigStepFst : {e : Term [] t} -> BigStep e _ -> Term [] t
bigStepFst {e = e} _ = e

bigStepSnd : {e : Term [] t} -> BigStep _ e -> Term [] t
bigStepSnd {e = e} _ = e

bigStepValue : BigStep _ e -> Value e
bigStepValue (BStValue v)     = v
bigStepValue (BStApp _ _ z)   = bigStepValue z
bigStepValue (BStFix _ z)     = bigStepValue z
bigStepValue (BStSucc z)      = VSucc (bigStepValue z)
bigStepValue (BStPredZero _)  = VZero
bigStepValue (BStPredSucc z)  = case bigStepValue z of
                                    VZero impossible
                                    VSucc v => v
bigStepValue (BStIfzZero _ z) = bigStepValue z
bigStepValue (BStIfzSucc _ z) = bigStepValue z

bigStepValueIrreducible : BigStep e1 e2 -> Value e1 -> e1 = e2
bigStepValueIrreducible (BStValue VZero) VZero   = Refl
bigStepValueIrreducible (BStValue v1) (VSucc v2) = Refl
bigStepValueIrreducible (BStSucc bst) (VSucc v)  =
  cong $ bigStepValueIrreducible bst v
bigStepValueIrreducible (BStValue v)  VAbs       = Refl

bigStepTransitive : BigStep e1 e2 -> BigStep e2 e3 -> BigStep e1 e3
bigStepTransitive (BStValue v) bst = bst
bigStepTransitive (BStApp x w t) y = BStApp x w $ bigStepTransitive t y
bigStepTransitive (BStFix x w) y = BStFix x $ bigStepTransitive w y
bigStepTransitive (BStSucc x) (BStValue v) = BStSucc x
bigStepTransitive (BStSucc x) (BStSucc y)  = BStSucc $ bigStepTransitive x y
bigStepTransitive (BStPredZero x) (BStValue v) = BStPredZero x
bigStepTransitive (BStPredSucc x) y = let bst1 = BStSucc y
                                          bst2 = bigStepTransitive x bst1
                                      in BStPredSucc bst2
bigStepTransitive (BStIfzZero w s) y = BStIfzZero w (bigStepTransitive s y)
bigStepTransitive (BStIfzSucc w s) y = BStIfzSucc w (bigStepTransitive s y)

-- End: BIG-STEP EVALUATION RELATION FOR TERMS IN THE LAMBDA CALCULUS
---------------------------------------------------------------------

-------------------------------------------------------
-- Begin: CO-INDUCTIVE RELATION FOR BIG-STEP EVALUATION

codata CoBigStep : Term [] t -> (y: Term [] t) -> Type where
  CoBStValue    : (v : Value e) -> CoBigStep e e
  --
  CoBStApp      : CoBigStep e1 (TAbs e1') ->
                  CoBigStep e2 e2' ->
                  CoBigStep (subst e2' First e1') e ->
                  CoBigStep (TApp e1 e2) e
  --
  CoBStFix      : CoBigStep e (TAbs e') ->
                  CoBigStep (subst (TFix (TAbs e')) First e') e'' ->
                  CoBigStep (TFix e) e''
  --
  CoBStSucc     : CoBigStep e e' ->
                  CoBigStep (TSucc e) (TSucc e')
  --
  CoBStPredZero : CoBigStep e TZero ->
                  CoBigStep (TPred e) TZero
  --
  CoBStPredSucc : CoBigStep e (TSucc e') ->
                  CoBigStep (TPred e) e'
  --
  CoBStIfzZero  : CoBigStep e1 TZero ->
                  CoBigStep e2 e ->
                  CoBigStep (TIfz e1 e2 _) e
  --
  CoBStIfzSucc  : CoBigStep e1 (TSucc _) ->
                  CoBigStep e3 e ->
                  CoBigStep (TIfz e1 _ e3) e

coBigStepValueIrreducible : CoBigStep e1 e2 -> Value e1 -> e1 = e2
coBigStepValueIrreducible (CoBStValue VZero) VZero      = Refl
coBigStepValueIrreducible (CoBStValue v1)    (VSucc v2) = Refl
coBigStepValueIrreducible (CoBStSucc cbst)   (VSucc v)  =
  cong $ coBigStepValueIrreducible cbst v
coBigStepValueIrreducible (CoBStValue v)     VAbs       = Refl

coBigStepTransitive : CoBigStep e1 e2 -> CoBigStep e2 e3 -> CoBigStep e1 e3
coBigStepTransitive (CoBStValue v) y = y
coBigStepTransitive (CoBStApp x z w) y = CoBStApp x z $ coBigStepTransitive w y
coBigStepTransitive (CoBStFix x z) y = CoBStFix x $ coBigStepTransitive z y
coBigStepTransitive (CoBStSucc x) (CoBStValue v) = CoBStSucc x
coBigStepTransitive (CoBStSucc x) (CoBStSucc y) = CoBStSucc $ coBigStepTransitive x y
coBigStepTransitive (CoBStPredZero x) (CoBStValue v) = CoBStPredZero x
coBigStepTransitive (CoBStPredSucc x) y = let cbst1 = CoBStSucc y
                                          in CoBStPredSucc $ coBigStepTransitive x cbst1
coBigStepTransitive (CoBStIfzZero z w) y = CoBStIfzZero z $ coBigStepTransitive w y
coBigStepTransitive (CoBStIfzSucc w s) y = CoBStIfzSucc w $ coBigStepTransitive s y

bigStepToCoBigStep : BigStep e1 e2 -> CoBigStep e1 e2
bigStepToCoBigStep (BStValue v) = CoBStValue v
bigStepToCoBigStep (BStApp bst1 bst2 bst3) = CoBStApp (bigStepToCoBigStep bst1)
                                                      (bigStepToCoBigStep bst2)
                                                      (bigStepToCoBigStep bst3)
bigStepToCoBigStep (BStFix bst1 bst2) = CoBStFix (bigStepToCoBigStep bst1)
                                                 (bigStepToCoBigStep bst2)
bigStepToCoBigStep (BStSucc bst) = CoBStSucc $ bigStepToCoBigStep bst
bigStepToCoBigStep (BStPredZero bst) = CoBStPredZero $ bigStepToCoBigStep bst
bigStepToCoBigStep (BStPredSucc bst) = CoBStPredSucc $ bigStepToCoBigStep bst
bigStepToCoBigStep (BStIfzZero bst1 bst2) = CoBStIfzZero (bigStepToCoBigStep bst1)
                                                         (bigStepToCoBigStep bst2)
bigStepToCoBigStep (BStIfzSucc bst1 bst2) = CoBStIfzSucc (bigStepToCoBigStep bst1)
                                                         (bigStepToCoBigStep bst2)

-- End: CO-INDUCTIVE RELATION FOR BIG-STEP EVALUATION
-----------------------------------------------------


isEven : Nat -> Bool
isEven Z = True
isEven (S k) = not $ isEven k


import Syntax.PreorderReasoning

-------- some notation ----------
infixr 6 .+.,:+:
infixr 7 .*.,:*:

interface Additive a where
  constructor MkAdditive
  (.+.) : a -> a -> a
  O   : a

interface Additive2 a where
  constructor MkAdditive2
  (:+:) : a -> a -> a
  O2   : a

interface Multiplicative a where
  constructor MkMultiplicative
  (.*.) : a -> a -> a
  I     : a

record MonoidOver U where
  constructor WithStruct
  Unit    : U
  Mult    : U -> U -> U
  lftUnit : (x : U) -> Unit `Mult` x    = x
  rgtUnit : (x : U) -> x    `Mult` Unit = x
  assoc   : (x,y,z : U)
                    -> x `Mult` (y `Mult` z) = (x `Mult` y) `Mult` z

record Monoid where
  constructor MkMonoid
  U : Type
  Struct : MonoidOver U

AdditiveStruct : (m : MonoidOver a) -> Additive a
AdditiveStruct m = MkAdditive (Mult $ m)
                              (Unit $ m)
AdditiveStruct2 : (m : MonoidOver a) -> Additive2 a
AdditiveStruct2 m = MkAdditive2 (Mult $ m)
                                (Unit $ m)
AdditiveStructs : (ma : MonoidOver a) -> (mb : MonoidOver b)
              -> (Additive a, Additive2 b)
AdditiveStructs ma mb = (AdditiveStruct ma, AdditiveStruct2 mb)

getAdditive : (m : Monoid) -> Additive (U m)
getAdditive m = AdditiveStruct (Struct m)

MultiplicativeStruct : (m : Monoid) -> Multiplicative (U m)
MultiplicativeStruct m = MkMultiplicative (Mult $ Struct m)
                                          (Unit $ Struct m)
-----------------------------------------------------

0 Commutative : MonoidOver a -> Type
Commutative m = (x,y : a) -> let _ = AdditiveStruct m in
                x .+. y = y .+. x

0 Commute : (Additive a, Additive2 a) => Type
Commute =
          (x11,x12,x21,x22 : a) ->
          ((x11 :+: x12) .+. (x21 :+: x22))
          =
          ((x11 .+. x21) :+: (x12 .+. x22))

product : (ma, mb : Monoid) -> Monoid
product ma mb =
  let
      %hint aStruct : Additive (U ma)
      aStruct = getAdditive ma
      %hint bStruct : Additive (U mb)
      bStruct = getAdditive mb

  in MkMonoid (U ma, U mb) $ WithStruct
     (O, O)
     (\(x1,y1), (x2, y2)  => (x1 .+. x2, y1 .+. y2))
     (\(x,y) => rewrite lftUnit (Struct ma) x in
                rewrite lftUnit (Struct mb) y in
                Refl)
     (\(x,y) => rewrite rgtUnit (Struct ma) x in
                rewrite rgtUnit (Struct mb) y in
                Refl)
     (\(x1,y1),(x2,y2),(x3,y3) =>
                rewrite assoc (Struct ma) x1 x2 x3 in
                rewrite assoc (Struct mb) y1 y2 y3 in
                Refl)

EckmannHilton : forall a . (ma,mb : MonoidOver a)
             -> let ops = AdditiveStructs ma mb in
                Commute @{ops}
             -> (Commutative ma, (x,y : a) -> x .+. y = x :+: y)
EckmannHilton ma mb prf =
  let %hint first : Additive a
      first = AdditiveStruct ma
      %hint second : Additive2 a
      second = AdditiveStruct2 mb in
  let SameUnits : (the a O === O2)
      SameUnits = Calc $
        |~ O
        ~~  O         .+.         O  ...(sym $ lftUnit ma O)
        ~~ (O :+: O2) .+. (O2 :+: O) ...(sym $ cong2 (.+.)
                                             (rgtUnit mb O)
                                             (lftUnit mb O))
        ~~ (O .+. O2) :+: (O2 .+. O) ...(prf O O2 O2 O)
        ~~        O2  :+:  O2        ...(cong2 (:+:)
                                             (lftUnit ma O2)
                                             (rgtUnit ma O2))
        ~~ O2                        ...(lftUnit mb O2)

      SameMults : (x,y : a) -> (x .+. y) === (x :+: y)
      SameMults x y = Calc $
        |~ x .+. y
        ~~ (x :+: O2) .+. (O2 :+: y) ...(sym $ cong2 (.+.)
                                             (rgtUnit mb x)
                                             (lftUnit mb y))
        ~~ (x .+. O2) :+: (O2 .+. y) ...(prf x O2 O2 y)
        ~~ (x .+. O ) :+: (O  .+. y) ...(cong (\u =>
                                              (x .+. u) :+: (u .+. y))
                                              (sym SameUnits))
        ~~ x :+: y                   ...(cong2 (:+:)
                                              (rgtUnit ma x)
                                              (lftUnit ma y))

      Commutativity : Commutative ma
      Commutativity x y = Calc $
        |~ x .+. y
        ~~ (O2 :+: x) .+. (y :+: O2) ...(sym $ cong2 (.+.)
                                             (lftUnit mb x)
                                             (rgtUnit mb y))
        ~~ (O2 .+. y) :+: (x .+. O2) ...(prf O2 x y O2)
        ~~ (O  .+. y) :+: (x .+. O ) ...(cong (\u =>
                                              (u .+. y) :+: (x .+. u))
                                              (sym SameUnits))
        ~~ y :+: x                   ...(cong2 (:+:)
                                              (lftUnit ma y)
                                              (rgtUnit ma x))
        ~~ y .+. x                   ...(sym $ SameMults y x)
  in (Commutativity, SameMults)


> module NonNegRational.tests.Main

> import NonNegRational.NonNegRational
> import NonNegRational.BasicOperations
> import NonNegRational.BasicProperties
> import Fraction.Fraction
> import Fraction.Predicates
> import Fraction.BasicOperations
> import PNat.PNat
> import PNat.Operations
> import PNat.Properties
> import Nat.Positive

> %default total
> %auto_implicits off

> x  : NonNegRational
> x  = fromFraction (2067, Element 616 MkPositive)

> y  : NonNegRational
> y  = fromFraction (32, Element 11 MkPositive)

> z  : NonNegRational
> z  = fromFraction (1, Element 13 MkPositive) -- segfaults with 'Element 12749 MkPositive'

> f1  : Fraction
> f1  = (1, Element 8 MkPositive)
> z1  : NonNegRational
> z1  = fromFraction f1

> f2  : Fraction
> f2  = (3, Element 24 MkPositive)
> z2  : NonNegRational
> z2  = fromFraction f2

> f1Eqf2 : f1 `Eq` f2
> f1Eqf2 = Refl

> z1EQz2 : z1 = z2
> z1EQz2 = fromFractionEqLemma f1 f2 f1Eqf2

> zs : List NonNegRational
> zs = [z1, z2]

> szs : sum zs = z1 + z2
> szs = Refl

> main : IO ()
> main = do putStrLn ("x           = " ++ show x)
>           putStrLn ("y           = " ++ show y)
>           putStrLn ("z           = " ++ show z)
>           putStrLn ("x + y       = " ++ show (x + y))
>           putStrLn ("y + x       = " ++ show (y + x))
>           putStrLn ("x * y       = " ++ show (x * y))
>           putStrLn ("y * x       = " ++ show (y * x))
>           putStrLn ("(x + y) + z = " ++ show ((x + y) + z))
>           putStrLn ("x + (y + z) = " ++ show (x + (y + z)))
>           putStrLn ("(x * y) * z = " ++ show ((x * y) * z))
>           putStrLn ("zs          = " ++ show zs)
>           putStrLn ("sum zs      = " ++ show (sum zs))


import Effects
import Effect.Exception
import Effect.StdIO
import Effect.Random
import Effect.System
import Data.Vect

%default total

--------------------------------------------------------------------------------
-- Operations on individual rows
--------------------------------------------------------------------------------

||| Fills in an array
fillIn : LTE n m -> a -> Vect n a -> Vect m a
fillIn LTEZero c []            = replicate _ c
fillIn (LTESucc w) c (x :: xs) = x :: (fillIn w c xs)

||| Filters out the Nothings from a vector of maybes.
|||
||| Takes a vector of length n with elements of type Maybe a
||| and returns the dependent pair (m ** (Vect m a, LTE m n)) where
||| m is the new length, Vect m a is the filtered list, and LTE m n
||| is a prove that m <= n, that is, that the new list has length
||| less than or equal to the original list.
filterMaybes : Vect n (Maybe a) -> (m ** (Vect m a, LTE m n))
filterMaybes []              = (Z ** ([], LTEZero))
filterMaybes (Just x :: xs)  = let (_ ** (ys, w)) = filterMaybes xs in
  (_ ** ((x :: ys), LTESucc w))
filterMaybes (Nothing :: xs) = let (_ ** (ys, w)) = filterMaybes xs in
  (_ ** (ys, lteSuccRight w))

||| The collapsing of pairs operation of the 2048 game.
|||
||| Takes a vector of elements of type a, and performs the "collapsing"
||| operation of the 2048 game.  This takes adjacent pairs, and if they
||| are equal, combines them into a single element with double the value.
||| Returns a vector of length m and proof that m <= n.
collapsePairs : (Num a, Eq a) => Vect n a -> (m ** (Vect m a, LTE m n))
collapsePairs (x::x'::xs) =
  if x == x' then
    let (_ ** (ys, w)) = collapsePairs xs in (_ ** ((2 * x) :: ys, lteSuccRight (LTESucc w)))
  else
    let (_ ** (ys, w)) = collapsePairs (x' :: xs) in (_ ** (x :: ys, LTESucc w))
collapsePairs (x::[])     = (_ ** ([x], LTESucc LTEZero))
collapsePairs []          = (_ ** ([], LTEZero))

||| The basic row operation of the 2048 game.
|||
||| Combines the operations of filterMaybes and collapsePairs,
||| and combines their proofs, and transitivity of <=, to
||| prove that the result of applying both operations is
||| a shorter vector than the original.  This proof is used
||| to apply the fillIn function.
basicRowOperation : (Eq a, Num a) => Vect n (Maybe a) -> Vect n (Maybe a)
basicRowOperation xs = let (m ** (ys, w)) = filterMaybes xs in let
  (l ** (zs, wPrime)) = collapsePairs ys in
  (fillIn (lteTransitive wPrime w) Nothing (map Just zs))

--------------------------------------------------------------------------------
-- Operations on the game board
--------------------------------------------------------------------------------

||| Takes the transpose of a rectangular array
transposeArray : Vect n (Vect m a) -> Vect m (Vect n a)
transposeArray []      = replicate _ []
transposeArray (x::xs) = zipWith (::) x (transposeArray xs)

||| Flattens a rectangular array
flattenArray : Vect n (Vect m a) -> Vect (n * m) a
flattenArray Nil     = Nil
flattenArray (x::xs) = x ++ (flattenArray xs)

||| Splits an array
split' : Vect (plus n m) a -> (Vect n a, Vect m a)
split' {n=Z} xs                = ([], xs)
split' {n=(S k)}{m=l} (x::xs) = let (ys, zs) = split' {n=k}{m=l} xs in
  (x::ys, zs)

||| Unflattens an array
unFlattenArray : Vect (n * m) a -> Vect n (Vect m a)
unFlattenArray {n=Z} Nil         = Nil
unFlattenArray {n=(S k)}{m=l} xs = let (ys, zs) = split' {n=l}{m=k*l} xs in
  (ys :: (unFlattenArray zs))

||| Find the indices of all elements of a vector that satisfy some test
findIndicesFin : (a -> Bool) -> Vect n a -> List (Fin n)
findIndicesFin f [] = []
findIndicesFin f (x::xs) = let tail = (map FS (findIndicesFin f xs)) in
  if f x then (FZ :: tail) else tail

--------------------------------------------------------------------------------
-- Display functions
--------------------------------------------------------------------------------

showValue : Show a => Maybe a -> String
showValue Nothing  = "...."
showValue (Just x) = pack (List.take 4 (unpack ((show x) ++ "....")))

showRow : Show a => Vect n (Maybe a) -> String
showRow []      = ""
showRow (x::xs) = (showValue x) ++ " " ++ (showRow xs)

showBoard : Show a => Vect m (Vect n (Maybe a)) -> String
showBoard []      = ""
showBoard (x::xs) = (showRow x) ++ "\n" ++ (showBoard xs)

--------------------------------------------------------------------------------
-- High level game logic
--------------------------------------------------------------------------------

Board : Type
Board = Vect 4 (Vect 4 (Maybe Int))

data Direction = Left | Right | Up | Down

partial
move : (Eq a, Num a) => Direction -> Vect m (Vect n (Maybe a)) -> Vect m (Vect n (Maybe a))
move Left  xs = map basicRowOperation xs
move Right xs = map (reverse . basicRowOperation . reverse) xs
move Up    xs = (transposeArray . (move Left) . transposeArray) xs
move Down  xs = (transposeArray . (move Right) . transposeArray) xs

-- myIndex : List (Fin 16) -> Maybe Nat
-- myIndex lst =
addRandomPiece : Board -> {[RND, EXCEPTION String]} Eff Board
addRandomPiece arr =
  case integerToFin 3 16 of
    Nothing => raise "Game Over"
    Just idx => pure (unFlattenArray (replaceAt idx (Just 2) flattened))
  where
    flattened : Vect 16 (Maybe Int)
    flattened = flattenArray arr
    indices : List (Fin 16)
    indices = findIndicesFin isNothing flattened

data UserAction = Quit | Invalid | Move Direction

getAction : Char -> UserAction
getAction 'a' = Move Left
getAction 'd' = Move Right
getAction 'w' = Move Up
getAction 's' = Move Down
getAction 'x' = Quit
getAction _   = Invalid

partial
mainLoop : Board -> {[RND, STDIO, EXCEPTION String]} Eff (Board)
mainLoop b = do putStrLn (showBoard b)
                c <- getChar
                performAction (getAction c)
    where
      partial
      performAction : UserAction -> {[RND, STDIO, EXCEPTION String]} Eff (Board)
      performAction Quit       = raise "You have quit"
      performAction Invalid    = mainLoop b
      performAction (Move dir) = let b' = move dir b in
        if b == b' then
          mainLoop b'
        else
          do
            b'' <- addRandomPiece b'
            mainLoop b''

partial
startGame : { [RND, STDIO, SYSTEM, EXCEPTION String] } Eff ()
startGame = do
  srand !time
  initialBoard <- addRandomPiece (replicate _ (replicate _ Nothing))
  mainLoop initialBoard
  pure ()

partial
main : IO ()
main = run startGame


data IsS : (Nat -> Nat) -> Type where
  Indeed : (s : Nat -> Nat) -> s === S -> IsS s

------------------------------------------------------------------------
-- 1.
-- the S pattern is forced by the fact the parameter is instantiated
-- so everything is fine

-- either left implicit
indeed : IsS S -> S === S
indeed (Indeed _ eq) = eq

-- or made explicit
indeed2 : IsS S -> S === S
indeed2 (Indeed S eq) = eq

------------------------------------------------------------------------
-- 2. The S pattern is not forced by the parameter (a generic variable)

-- either don't match on it
indeed3 : IsS s -> s === S
indeed3 (Indeed s eq) = eq

-- or match on the proof that forces it
indeed4 : IsS s -> s === S
indeed4 (Indeed S Refl) = Refl
--              ^ forced by Refl

-- If you don't: too bad!
fail : IsS s -> s === S
fail (Indeed S eq) = eq
--             ^ not Refl, S not forced! OUCH


module Backprop.Math

import Backprop.CanBack
import Backprop.Node
import Control.Optics
import public Data.Floating
import public Data.Num

export
view : {a, b : _} -> CanBack a => Simple Lens a b -> Node i a -> Node i b
view l = op1 $ \[x] => (x ^. l, \d => [set l d zero])

infixl 0 ^.
export
(^.) : {a, b : _} -> CanBack a => Node i a -> Simple Lens a b -> Node i b
x ^. l = view l x

export
sum : {a : _} -> (CanBack a, NodeFunctor f, Num a, Foldable f) => Node i (f a) -> Node i a
sum x = Prelude.sum $ Node.sequence x

export
max, min : {a : _} -> (CanBack a, Num a, Ord a) => Node i a -> Node i a -> Node i a
max = op2 $ \[x, y] => (max x y, \d => [d * if x > y then 1 else 0, d * if y > x then 1 else 0])
min = op2 $ \[x, y] => (min x y, \d => [d * if x < y then 1 else 0, d * if y < x then 1 else 0])

-- machine learning specific

export
relu : {a : _} -> (CanBack a, Num a, Ord a) => Node i a -> Node i a
relu x = max 0 x


{-
  Calulator parser

  number ::= [ "-" ] digit { digit }.
  digit  ::= "0" | "1" | ... | "8" | "9".
  expr   ::= term { addop term }.
  term   ::= factor { mulop factor }.
  factor ::= "(" expr ")" | number.
  addop  ::= "+" | "-".
  mulop  ::= "*".

-}
module Test.Calculator

import NanoParsec.Parser
import NanoParsec.Combinators

data Expr = Add Expr Expr
          | Mul Expr Expr
          | Sub Expr Expr
          | Lit Int
          deriving Show

eval :: Expr -> Int
eval ex = case ex of
    Add a b -> eval a + eval b
    Mul a b -> eval a * eval b
    Sub a b -> eval a - eval b
    Lit n   -> n

int :: Parser Expr
int = number >>= \n -> return (Lit n)

expr :: Parser Expr
expr = term `chainl1` addop

term :: Parser Expr
term = factor `chainl1` mulop

factor :: Parser Expr
factor = int <|> parens expr

infixOp :: String -> (a -> a -> a) -> Parser (a -> a -> a)
infixOp x f = reserved x >>= \_ => return f

addop :: Parser (Expr -> Expr -> Expr)
addop = (infixOp "+" Add) <|> (infixOp "-" Sub)

mulop :: Parser (Expr -> Expr -> Expr)
mulop = infixOp "*" Mul


module Nat

public export
data Nat = Z | S Nat

public export
plus : Nat -> Nat -> Nat
plus Z y = y
plus (S k) y = S (plus k y)


-- Exercise 1
total
same_cons :  {xs : List a}
          -> {ys : List a}
          -> xs = ys
          -> x :: xs = x :: ys
same_cons Refl = Refl

-- Exercise 2
same_list :  {xs : List a}
          -> {ys : List a}
          -> x = y
          -> xs = ys
          -> x :: xs = y :: ys
same_list Refl Refl = Refl

-- Exercise 3
data ThreeEq : a -> b -> c -> Type where
  AllSame : ThreeEq x x x

-- Exercise 4
allSameS : (x, y, z : Nat) -> ThreeEq x y z -> ThreeEq (S x) (S y) (S z)
allSameS x x x AllSame = AllSame


> module Main

> import Data.Fin
> import Data.Vect
> import Data.Matrix
> import Data.Matrix.Numeric

> %default total
> %access public export
> %auto_implicits off

* Preliminaries

This is a re-implementation of

  https://gist.github.com/mrkgnao/a45059869590d59f05100f4120595623

which, in turn, is an Idris implementation of

  https://blog.jle.im/entry/practical-dependent-types-in-haskell-1.html

* Layers

A layer of type |A| with |n| inputs and |m| outputs is a vector of |m|
elements of type |A| (the biases) and a |m| x |n| matrix of elements of
type |A| (the weights):

> data Layer : Nat -> Nat -> Type -> Type where
>   MkLayer : {m, n : Nat} -> {A : Type} ->
>             (biases : Vect m A) -> (weights : Matrix m n A) -> Layer n m A

* Sequential neural networks

A sequential neural network of type |A| with |n| inputs, |m| outputs and
a sequence of intermediate layers is a sequence of layers of type
|A|. It can consist of either a single (Output) layer or of a layer with
|n| inputs and |k| outputs together with a network with |k| inputs and
|m| outputs:

> infixr 5 :>:

> data Network : Nat -> List Nat -> Nat -> Type -> Type where
>   Output : {n, m : Nat} -> {A : Type} ->
>            Layer n m A -> Network n [] m A
>   (:>:)  : {n, k, m : Nat} -> {ks : List Nat} -> {A : Type} ->
>            Layer n k A -> Network k ks m A -> Network n (k :: ks) m A

* Feed-forward

The idea is that, given a sequential neural network of type |A| with |n|
inputs and |m| outputs and a vector of |n| inputs of matching type, one
can compute a vector of |n| outputs.

The computation is called feed-forward. It requires |A| to implement
addition and multiplication and depends on an "activation" function |s :
A -> A|:

> feedForward : {n, m : Nat} -> {ks : List Nat} -> {A : Type} -> Num A =>
>               (A -> A) -> Vect n A -> Network n ks m A -> Vect m A

The idea is to feed the input into the first layer and pass its output
(activated through |s|) as input for the next layer. With

> evalLayer : {n, m : Nat} -> {t : Type} -> Num t =>
>             Vect n t -> Layer n m t -> Vect m t
> evalLayer {n} {m} {t} input (MkLayer biases weights) = output where
>   output : Vect m t
>   output = biases + (weights </> input)

the implementation of |feedForward| is trivial:

> feedForward s input (Output l) = map s (evalLayer input l)
> feedForward s input (l :>: ls) = feedForward s (map s (evalLayer input l)) ls

* Error

Given a training pair |(x, y)|, the error is simply the difference
between |y| and the output of the network when fed with the input |x|:

> error : {n, m : Nat} -> {ks : List Nat} -> {t : Type} -> Num t => Neg t =>
>         (t -> t) -> Vect n t -> Vect m t -> Network n ks m t -> Vect m t
> error {m} {t} s input target network = target - output where
>   output : Vect m t
>   output = (feedForward s input network)

* Back propagation

> backPropagation : {n, m : Nat} -> {ks : List Nat} -> {t : Type} ->
>                   Num t => Neg t =>
>                   (s      : t -> t) ->
>                   (s'     : t -> t) ->
>                   (eta    : t) ->
>                   (input  : Vect n t) ->
>                   (target : Vect m t) ->
>                   Network n ks m t -> Network n ks m t

> backPropagation {t} s s' eta input target net = fst (go input target net)
>
>   where go : {n, m : Nat} -> {ks : List Nat} ->
>              Vect n t -> Vect m t ->  Network n ks m t -> (Network n ks m t, Vect n t)
>
>         go input target ((MkLayer bias weights) :>: rest) =
>           let y             = evalLayer input (MkLayer bias weights)
>               output        = map s y
>               (rest', dWs') = go output target rest
>               dEdy          = (map s' y) * dWs'
>               bias'         = bias - (eta <# dEdy)
>               weights'      = weights - (eta <#> (dEdy >< input))
>               layer'        = (MkLayer bias' weights')
>               dWs           = (transpose weights) </> dEdy
>           in (layer' :>: rest', dWs)
>
>         go input target (Output (MkLayer bias weights)) =
>           let y        = evalLayer input (MkLayer bias weights)
>               output   = map s y
>               dEdy     = (map s' y) * (output - target)
>               bias'    = bias - (eta <# dEdy)
>               weights' = weights - (eta <#> (dEdy >< input))
>               layer'   = (MkLayer bias' weights')
>               dWs      = (transpose weights) </> dEdy
>           in (Output layer', dWs)

* Example

> initial : Network 2 [2] 2 Double
> initial = first :>: second
>   where first  = MkLayer [0.35, 0.35]
>                          [ [0.15, 0.20],
>                            [0.25, 0.30]
>                          ]
>         second = Output
>                $ MkLayer [0.60, 0.60]
>                          [ [0.40, 0.45],
>                            [0.50, 0.55]
>                          ]

> input : Vect 2 Double
> input = [0.05,0.10]

> target : Vect 2 Double
> target = [0.01,0.99]

> s : Double -> Double
> s x = 1 / (1 + exp (-x))

> s' : Double -> Double
> s' x = (s x) * (1 - s x)

> main : IO ()
> main = let step   = backPropagation s s' 0.5 input target
>            errorF = error s input target
>            states = iterate step initial
>        in putStrLn . unlines $ map (show . errorF) (take 100 states)

> {-

> ---}


module Main

import System
import Effects
import Effect.Random
import Data.Vect

total
insert : Ord a => a -> Vect n a -> Vect (S n) a
insert x [] = [x]
insert x (y :: ys) = if (x < y) then x :: y :: ys else y :: insert x ys

vsort : Ord a => Vect n a -> Vect n a
vsort [] = []
vsort (x :: xs) = insert x (vsort xs)

mkSortVec : (n : Nat) -> Eff (Vect n Int) [RND]
mkSortVec Z = pure []
mkSortVec (S k) = pure (fromInteger !(rndInt 0 10000) :: !(mkSortVec k))

main : IO ()
main = do
    arg <- getLine
    let vec = runPure $ (srand 123456789 *> mkSortVec (fromInteger (cast arg)))
    putStrLn "Made vector"
    printLn (vsort vec)


module Data.OrderedSet

import public Data.DistinctElements

%access public export
%default total

data OrderedSet : Nat -> Type -> Type where
    FromVect : (xs : Vect n a) -> {auto p : DistinctElements xs} -> OrderedSet n a

Elem : a -> OrderedSet n a -> Type
Elem x (FromVect xs) = Elem x xs

Nil : OrderedSet Z a
Nil = FromVect []

(::) : (x : a) -> (xs : OrderedSet n a) -> {default absurd p : Not (Elem x xs)} -> OrderedSet (S n) a
(::) x (FromVect xs {p = ps}) {p = p} = FromVect (x::xs) {p = (p,ps)}

tail : OrderedSet (S n) a -> OrderedSet n a
tail (FromVect (_ :: xs) {p = (_, ps)}) = FromVect xs

isElem : DecEq a => (x : a) -> (xs : OrderedSet n a) -> Dec (Elem x xs)
isElem x (FromVect xs) = isElem x xs

toVect : OrderedSet n a -> Vect n a
toVect (FromVect xs) = xs

map : {f : a -> b} -> Injective f -> OrderedSet n a -> OrderedSet n b
map inj (FromVect xs {p}) {f} = FromVect (map f xs) {p = mapInjectiveFunction inj p}


import Data.Vect

tryIndex : {n : _} -> Integer -> Vect n a -> Maybe a
tryIndex {n} i xs = case integerToFin i n of
                         Nothing => Nothing
                         Just idx => Just (index idx xs)


module Hardware

import Data.Vect

Gate : Type
Gate = Bool -> Bool -> Bool

nand : Gate
nand True True = False
nand a    b    = True

and : Gate
and a b = nand (nand a b) (nand a b)

or : Gate
or a b = nand (nand a a) (nand b b)

not : Bool -> Bool
not a = nand a a

nor : Gate
nor a b = nand q q
  where
    q = nand (nand a a) (nand b b)

xor : Gate
xor a b = nand d e
  where
    c : Bool
    c = nand a b
    d = nand c a
    e = nand c b

halfAdder : Bool -> Bool -> (Bool, Bool)
halfAdder a b = (xor a b, and a b)

fullAdder : Bool -> Bool -> Bool -> (Bool, Bool)
fullAdder a b c = (xor a (xor b c), or (and a b) (and c (xor a b)))

Word : Nat -> Type
Word n = Vect n Bool

Byte : Type
Byte = Word 8

rippleCarry : Word n -> Word n -> Word n
rippleCarry x y = go False x y
  where
    go : Bool -> Vect n Bool -> Vect n Bool -> Vect n Bool
    go carry [] [] = Data.Vect.Nil
    go carry (a :: as) (b :: bs) =
      let (s, c) = fullAdder a b carry
       in s :: go c as bs

zero' : Byte
zero' = replicate 8 False

zero : Word n
zero {n} = replicate n False

one : Word (S n)
one {n} = True :: replicate n False

two : Byte
two = rippleCarry one one

three : Byte
three = rippleCarry one two

four : Byte
four = rippleCarry one three


module Main

pythag : Int -> List (Int, Int, Int)
pythag max = [(x, y, z) | z <- [1..max], y <- [1..z], x <- [1..y],
                          x * x + y *y == z * z]

println : Show a => a -> IO ()
println a = do
  print a
  putStrLn ""

main : IO ()
main = print (pythag 50)


||| Convert binary string to an integer
module BinToDec

import Data.Nat.Exponentiation

data BinChar : Char -> Type where
  O : BinChar '0'
  I : BinChar '1'

data Every : (a -> Type) -> List a -> Type where
  Nil : {P : a -> Type} -> Every P []
  (::) : {P : a -> Type} -> P x -> Every P xs -> Every P (x :: xs)

fromBinChars : Every BinChar xs -> Nat -> Nat
fromBinChars [] _ = 0
fromBinChars (_ :: ys) Z = 1
fromBinChars (O :: ys) (S k) = fromBinChars ys k
fromBinChars (I :: ys) (S k) = lpow 2 k + fromBinChars ys k

b : (s : String) -> {auto p : Every BinChar (unpack s)} -> Nat
b {p} s = fromBinChars p (length s)


import Data.Vect

insert : Ord elem =>
         (x : elem) -> (xsSorted : Vect len elem) -> Vect (S len) elem
insert x [] = [x]
insert x (y :: xs) = case x < y of
                          False => y :: insert x xs
                          True => x :: y :: xs

insSort : Ord elem => Vect n elem -> Vect n elem
insSort [] = []
insSort (x :: xs) = let xsSorted = insSort xs in
                        insert x xsSorted


plus' : Nat -> Nat -> Nat
plus' Z     y = y
plus' (S k) y = S (plus' k y)

mult' : Nat -> Nat -> Nat
mult' Z     y = Z
mult' (S k) y = plus' y (mult' k y)


||| We define some meta types that help with specification of syntax.
|||
||| We need some types to facilitate a nameless representation (De Bruijn indicies) for recursion variables.
|||
||| We need types for local branch and selection
module Sessions.Meta

import Decidable.Equality

%default total

public export
data Ty = R -- recursion variable
        | G -- protocol

public export
data ChoiceTy = BRANCH | SELECT

notBS : BRANCH = SELECT -> Void
notBS Refl impossible

export
DecEq ChoiceTy where
  decEq BRANCH BRANCH = Yes Refl
  decEq BRANCH SELECT = No notBS
  decEq SELECT BRANCH = No (negEqSym notBS)
  decEq SELECT SELECT = Yes Refl

public export
DecEq : (typeR, typeL, typeR : Type)
     -> Type
DecEq a b c = (DecEq a, DecEq b, DecEq c)

-- [ EOF ]


module Data.Fin.Extra

import Data.Fin
import Data.Nat

import Syntax.WithProof
import Syntax.PreorderReasoning

%default total

-------------------------------
--- `finToNat`'s properties ---
-------------------------------

||| A Fin's underlying natural number is smaller than the bound
export
elemSmallerThanBound : (n : Fin m) -> LT (finToNat n) m
elemSmallerThanBound FZ = LTESucc LTEZero
elemSmallerThanBound (FS x) = LTESucc (elemSmallerThanBound x)

||| Last's underlying natural number is the bound's predecessor
export
finToNatLastIsBound : {n : Nat} -> finToNat (Fin.last {n}) = n
finToNatLastIsBound {n=Z} = Refl
finToNatLastIsBound {n=S k} = cong S finToNatLastIsBound

||| Weaken does not modify the underlying natural number
export
finToNatWeakenNeutral : {n : Fin m} -> finToNat (weaken n) = finToNat n
finToNatWeakenNeutral = finToNatQuotient (weakenNeutral n)

||| WeakenN does not modify the underlying natural number
export
finToNatWeakenNNeutral : (0 m : Nat) -> (k : Fin n) ->
                         finToNat (weakenN m k) = finToNat k
finToNatWeakenNNeutral m k = finToNatQuotient (weakenNNeutral m k)

||| `Shift k` shifts the underlying natural number by `k`.
export
finToNatShift : (k : Nat) -> (a : Fin n) -> finToNat (shift k a) = k + finToNat a
finToNatShift Z     a = Refl
finToNatShift (S k) a = cong S (finToNatShift k a)

-------------------------------------------------
--- Inversion function and related properties ---
-------------------------------------------------

||| Compute the Fin such that `k + invFin k = n - 1`
public export
invFin : {n : Nat} -> Fin n -> Fin n
invFin FZ = last
invFin (FS k) = weaken (invFin k)

export
invFinSpec : {n : _} -> (i : Fin n) -> 1 + finToNat i + finToNat (invFin i) = n
invFinSpec {n = S k} FZ = cong S finToNatLastIsBound
invFinSpec (FS k) = let H = invFinSpec k in
  let h = finToNatWeakenNeutral {n = invFin k} in
  cong S (rewrite h in H)

||| The inverse of a weakened element is the successor of its inverse
export
invFinWeakenIsFS : {n : Nat} -> (m : Fin n) -> invFin (weaken m) = FS (invFin m)
invFinWeakenIsFS FZ = Refl
invFinWeakenIsFS (FS k) = cong weaken (invFinWeakenIsFS k)

export
invFinLastIsFZ : {n : Nat} -> invFin (last {n}) = FZ
invFinLastIsFZ {n = Z} = Refl
invFinLastIsFZ {n = S n} = cong weaken (invFinLastIsFZ {n})

||| `invFin` is involutive (i.e. applied twice it is the identity)
export
invFinInvolutive : {n : Nat} -> (m : Fin n) -> invFin (invFin m) = m
invFinInvolutive FZ = invFinLastIsFZ
invFinInvolutive (FS k) = Calc $
   |~ invFin (invFin (FS k))
   ~~ invFin (weaken (invFin k)) ...( Refl )
   ~~ FS (invFin (invFin k))     ...( invFinWeakenIsFS (invFin k) )
   ~~ FS k                       ...( cong FS (invFinInvolutive k) )

--------------------------------
--- Strengthening properties ---
--------------------------------

||| It's possible to strengthen a weakened element of Fin **m**.
export
strengthenWeakenIsRight : (n : Fin m) -> strengthen (weaken n) = Just n
strengthenWeakenIsRight FZ = Refl
strengthenWeakenIsRight (FS k) = rewrite strengthenWeakenIsRight k in Refl

||| It's not possible to strengthen the last element of Fin **n**.
export
strengthenLastIsLeft : {n : Nat} -> strengthen (Fin.last {n}) = Nothing
strengthenLastIsLeft {n=Z} = Refl
strengthenLastIsLeft {n=S k} = rewrite strengthenLastIsLeft {n=k} in Refl

||| It's possible to strengthen the inverse of a succesor
export
strengthenNotLastIsRight : {n : Nat} -> (m : Fin n) -> strengthen (invFin (FS m)) = Just (invFin m)
strengthenNotLastIsRight m = strengthenWeakenIsRight (invFin m)

||| Either tightens the bound on a Fin or proves that it's the last.
export
strengthen' : {n : Nat} -> (m : Fin (S n)) ->
              Either (m = Fin.last) (m' : Fin n ** finToNat m = finToNat m')
strengthen' {n = Z} FZ = Left Refl
strengthen' {n = S k} FZ = Right (FZ ** Refl)
strengthen' {n = S k} (FS m) = case strengthen' m of
    Left eq => Left $ cong FS eq
    Right (m' ** eq) => Right (FS m' ** cong S eq)

----------------------------
--- Weakening properties ---
----------------------------

export
weakenNZeroIdentity : (k : Fin n) ->  weakenN 0 k ~~~ k
weakenNZeroIdentity FZ = FZ
weakenNZeroIdentity (FS k) = FS (weakenNZeroIdentity k)

export
shiftFSLinear : (m : Nat) -> (f : Fin n) -> shift m (FS f) ~~~ FS (shift m f)
shiftFSLinear Z     f = reflexive
shiftFSLinear (S m) f = FS (shiftFSLinear m f)

export
shiftLastIsLast : (m : Nat) -> {n : Nat} ->
                  shift m (Fin.last {n}) ~~~ Fin.last {n=m+n}
shiftLastIsLast Z = reflexive
shiftLastIsLast (S m) = FS (shiftLastIsLast m)

-----------------------------------
--- Division-related properties ---
-----------------------------------

||| A view of Nat as a quotient of some number and a finite remainder.
public export
data FractionView : (n : Nat) -> (d : Nat) -> Type where
    Fraction : (n : Nat) -> (d : Nat) -> {auto ok: GT d Z} ->
                (q : Nat) -> (r : Fin d) ->
                q * d + finToNat r = n -> FractionView n d

||| Converts Nat to the fractional view with a non-zero divisor.
export
divMod : (n, d : Nat) -> {auto ok: GT d Z} -> FractionView n d
divMod Z (S d) = Fraction Z (S d) Z FZ Refl
divMod {ok=_} (S n) (S d) =
    let Fraction {ok=ok} n (S d) q r eq = divMod n (S d) in
    case strengthen' r of
        Left eq' => Fraction {ok=ok} (S n) (S d) (S q) FZ $
            rewrite sym eq in
                rewrite trans (cong finToNat eq') finToNatLastIsBound in
                    cong S $ trans
                        (plusZeroRightNeutral (d + q * S d))
                        (plusCommutative d (q * S d))
        Right (r' ** eq') => Fraction {ok=ok} (S n) (S d) q (FS r') $
            rewrite sym $ plusSuccRightSucc (q * S d) (finToNat r') in
                cong S $ trans (sym $ cong (plus (q * S d)) eq') eq

-------------------
--- Conversions ---
-------------------

||| Total function to convert a nat to a Fin, given a proof
||| that it is less than the bound.
public export
natToFinLTE : (n : Nat) -> (0 _ : LT n m) -> Fin m
natToFinLTE Z     (LTESucc _) = FZ
natToFinLTE (S k) (LTESucc l) = FS $ natToFinLTE k l

||| Converting from a Nat to a Fin and back is the identity.
public export
natToFinToNat :
  (n : Nat)
  -> (lte : LT n m)
  -> finToNat (natToFinLTE n lte) = n
natToFinToNat 0 (LTESucc lte) = Refl
natToFinToNat (S k) (LTESucc lte) = cong S (natToFinToNat k lte)

----------------------------------------
--- Result-type changing arithmetics ---
----------------------------------------

||| Addition of `Fin`s as bounded naturals.
||| The resulting type has the smallest possible bound
||| as illustated by the relations with the `last` function.
public export
(+) : {m, n : Nat} -> Fin m -> Fin (S n) -> Fin (m + n)
(+) FZ y = coerce (cong S $ plusCommutative n (pred m)) (weakenN (pred m) y)
(+) (FS x) y = FS (x + y)

||| Multiplication of `Fin`s as bounded naturals.
||| The resulting type has the smallest possible bound
||| as illustated by the relations with the `last` function.
public export
(*) : {m, n : Nat} -> Fin (S m) -> Fin (S n) -> Fin (S (m * n))
(*) FZ _ = FZ
(*) {m = S _} (FS x) y = y + x * y

--- Properties ---

-- Relation between `+` and `*` and their counterparts on `Nat`

export
finToNatPlusHomo : {m, n : Nat} -> (x : Fin m) -> (y : Fin (S n)) ->
                   finToNat (x + y) = finToNat x + finToNat y
finToNatPlusHomo FZ _
  = finToNatQuotient $ transitive
     (coerceEq _)
     (weakenNNeutral _ _)
finToNatPlusHomo (FS x) y = cong S (finToNatPlusHomo x y)

export
finToNatMultHomo : {m, n : Nat} -> (x : Fin (S m)) -> (y : Fin (S n)) ->
                   finToNat (x * y) = finToNat x * finToNat y
finToNatMultHomo FZ _ = Refl
finToNatMultHomo {m = S _} (FS x) y = Calc $
  |~ finToNat (FS x * y)
  ~~ finToNat (y + x * y)                 ...( Refl )
  ~~ finToNat y + finToNat (x * y)        ...( finToNatPlusHomo y (x * y) )
  ~~ finToNat y + finToNat x * finToNat y ...( cong (finToNat y +) (finToNatMultHomo x y) )
  ~~ finToNat (FS x) * finToNat y         ...( Refl )

-- Relations to `Fin`'s `last`

export
plusPreservesLast : (m, n : Nat) -> Fin.last {n=m} + Fin.last {n} = Fin.last
plusPreservesLast Z     n
  = homoPointwiseIsEqual $ transitive
      (coerceEq _)
      (weakenNNeutral _ _)
plusPreservesLast (S m) n = cong FS (plusPreservesLast m n)

export
multPreservesLast : (m, n : Nat) -> Fin.last {n=m} * Fin.last {n} = Fin.last
multPreservesLast Z n = Refl
multPreservesLast (S m) n = Calc $
  |~ last + (last * last)
  ~~ last + last          ...( cong (last +) (multPreservesLast m n) )
  ~~ last                 ...( plusPreservesLast n (m * n) )

-- General addition properties

export
plusSuccRightSucc : {m, n : Nat} -> (left : Fin m) -> (right : Fin (S n)) ->
                    FS (left + right) ~~~ left + FS right
plusSuccRightSucc FZ        right = FS $ congCoerce reflexive
plusSuccRightSucc (FS left) right = FS $ plusSuccRightSucc left right

-- Relations to `Fin`-specific `shift` and `weaken`

export
shiftAsPlus : {m, n : Nat} -> (k : Fin (S m)) ->
              shift n k ~~~ last {n} + k
shiftAsPlus {n=Z}   k =
  symmetric $ transitive (coerceEq _) (weakenNNeutral _ _)
shiftAsPlus {n=S n} k = FS (shiftAsPlus k)

export
weakenNAsPlusFZ : {m, n : Nat} -> (k : Fin n) ->
                  weakenN m k = k + the (Fin (S m)) FZ
weakenNAsPlusFZ FZ = Refl
weakenNAsPlusFZ (FS k) = cong FS (weakenNAsPlusFZ k)

export
weakenNPlusHomo : {0 m, n : Nat} -> (k : Fin p) ->
                  weakenN n (weakenN m k) ~~~ weakenN (m + n) k
weakenNPlusHomo FZ = FZ
weakenNPlusHomo (FS k) = FS (weakenNPlusHomo k)

export
weakenNOfPlus :
  {m, n : Nat} -> (k : Fin m) -> (l : Fin (S n)) ->
  weakenN w (k + l) ~~~ weakenN w k + l
weakenNOfPlus FZ l
  = transitive (congWeakenN (coerceEq _))
  $ transitive (weakenNPlusHomo l)
  $ symmetric (coerceEq _)
weakenNOfPlus (FS k) l = FS (weakenNOfPlus k l)
-- General addition properties (continued)

export
plusZeroLeftNeutral : (k : Fin (S n)) -> FZ + k ~~~ k
plusZeroLeftNeutral k = transitive (coerceEq _) (weakenNNeutral _ k)

export
congPlusLeft : {m, n, p : Nat} -> {k : Fin m} -> {l : Fin n} ->
               (c : Fin (S p)) -> k ~~~ l -> k + c ~~~ l + c
congPlusLeft c FZ
  = transitive (plusZeroLeftNeutral c)
               (symmetric $ plusZeroLeftNeutral c)
congPlusLeft c (FS prf) = FS (congPlusLeft c prf)

export
plusZeroRightNeutral : (k : Fin m) -> k + FZ ~~~ k
plusZeroRightNeutral FZ = FZ
plusZeroRightNeutral (FS k) = FS (plusZeroRightNeutral k)

export
congPlusRight : {m, n, p : Nat} -> {k : Fin (S n)} -> {l : Fin (S p)} ->
                (c : Fin m) -> k ~~~ l -> c + k ~~~ c + l
congPlusRight c FZ
  = transitive (plusZeroRightNeutral c)
               (symmetric $ plusZeroRightNeutral c)
congPlusRight {n = S _} {p = S _} c (FS prf)
  = transitive (symmetric $ plusSuccRightSucc c _)
  $ transitive (FS $ congPlusRight c prf)
               (plusSuccRightSucc c _)
congPlusRight {p = Z} c (FS prf) impossible

export
plusCommutative : {m, n : Nat} -> (left : Fin (S m)) -> (right : Fin (S n)) ->
                  left + right ~~~ right + left
plusCommutative FZ        right
  = transitive (plusZeroLeftNeutral right)
               (symmetric $ plusZeroRightNeutral right)
plusCommutative {m = S _} (FS left) right
  = transitive (FS (plusCommutative left right))
               (plusSuccRightSucc right left)

export
plusAssociative :
  {m, n, p : Nat} ->
  (left : Fin m) -> (centre : Fin (S n)) -> (right : Fin (S p)) ->
  left + (centre + right) ~~~ (left + centre) + right
plusAssociative FZ centre right
  = transitive (plusZeroLeftNeutral (centre + right))
               (congPlusLeft right (symmetric $ plusZeroLeftNeutral centre))
plusAssociative (FS left) centre right = FS (plusAssociative left centre right)

-------------------------------------------------
--- Splitting operations and their properties ---
-------------------------------------------------

||| Converts `Fin`s that are used as indexes of parts to an index of a sum.
|||
||| For example, if you have a `Vect` that is a concatenation of two `Vect`s and
||| you have an index either in the first or the second of the original `Vect`s,
||| using this function you can get an index in the concatenated one.
public export
indexSum : {m : Nat} -> Either (Fin m) (Fin n) -> Fin (m + n)
indexSum (Left  l) = weakenN n l
indexSum (Right r) = shift m r

||| Extracts an index of the first or the second part from the index of a sum.
|||
||| For example, if you have a `Vect` that is a concatenation of the `Vect`s and
||| you have an index of this `Vect`, you have get an index of either left or right
||| original `Vect` using this function.
public export
splitSum : {m : Nat} -> Fin (m + n) -> Either (Fin m) (Fin n)
splitSum {m=Z}   k      = Right k
splitSum {m=S m} FZ     = Left FZ
splitSum {m=S m} (FS k) = mapFst FS $ splitSum k

||| Calculates the index of a square matrix of size `a * b` by indices of each side.
public export
indexProd : {n : Nat} -> Fin m -> Fin n -> Fin (m * n)
indexProd FZ     = weakenN $ mult (pred m) n
indexProd (FS k) = shift n . indexProd k

||| Splits the index of a square matrix of size `a * b` to indices of each side.
public export
splitProd : {m, n : Nat} -> Fin (m * n) -> (Fin m, Fin n)
splitProd {m=S _} p = case splitSum p of
  Left  k => (FZ, k)
  Right l => mapFst FS $ splitProd l

--- Properties ---

export
indexSumPreservesLast :
  (m, n : Nat) -> indexSum {m} (Right $ Fin.last {n}) ~~~ Fin.last {n=m+n}
indexSumPreservesLast Z     n = reflexive
indexSumPreservesLast (S m) n = FS (shiftLastIsLast m)

export
indexProdPreservesLast : (m, n : Nat) ->
         indexProd (Fin.last {n=m}) (Fin.last {n}) = Fin.last
indexProdPreservesLast Z n = homoPointwiseIsEqual
  $ transitive (weakenNZeroIdentity last)
               (congLast (sym $ plusZeroRightNeutral n))
indexProdPreservesLast (S m) n = Calc $
  |~ indexProd (last {n=S m}) (last {n})
  ~~ FS (shift n (indexProd last last)) ...( Refl )
  ~~ FS (shift n last)                  ...( cong (FS . shift n) (indexProdPreservesLast m n ) )
  ~~ last                               ...( homoPointwiseIsEqual prf )

  where

    prf : shift (S n) (Fin.last {n = n + m * S n}) ~~~ Fin.last {n = n + S (n + m * S n)}
    prf = transitive (shiftLastIsLast (S n))
                     (congLast (plusSuccRightSucc n (n + m * S n)))

export
splitSumOfWeakenN : (k : Fin m) -> splitSum {m} {n} (weakenN n k) = Left k
splitSumOfWeakenN FZ = Refl
splitSumOfWeakenN (FS k) = cong (mapFst FS) $ splitSumOfWeakenN k

export
splitSumOfShift : {m : Nat} -> (k : Fin n) -> splitSum {m} {n} (shift m k) = Right k
splitSumOfShift {m=Z}   k = Refl
splitSumOfShift {m=S m} k = cong (mapFst FS) $ splitSumOfShift k

export
splitOfIndexSumInverse : {m : Nat} -> (e : Either (Fin m) (Fin n)) -> splitSum (indexSum e) = e
splitOfIndexSumInverse (Left l) = splitSumOfWeakenN l
splitOfIndexSumInverse (Right r) = splitSumOfShift r

export
indexOfSplitSumInverse : {m, n : Nat} -> (f : Fin (m + n)) -> indexSum (splitSum {m} {n} f) = f
indexOfSplitSumInverse {m=Z}   f  = Refl
indexOfSplitSumInverse {m=S _} FZ = Refl
indexOfSplitSumInverse {m=S _} (FS f) with (indexOfSplitSumInverse f)
  indexOfSplitSumInverse {m=S _} (FS f) | eq with (splitSum f)
    indexOfSplitSumInverse {m=S _} (FS _) | eq | Left  _ = cong FS eq
    indexOfSplitSumInverse {m=S _} (FS _) | eq | Right _ = cong FS eq

export
splitOfIndexProdInverse : {m : Nat} -> (k : Fin m) -> (l : Fin n) ->
                          splitProd (indexProd k l) = (k, l)
splitOfIndexProdInverse FZ     l
   = rewrite splitSumOfWeakenN {n = mult (pred m) n} l in Refl
splitOfIndexProdInverse (FS k) l
   = rewrite splitSumOfShift {m=n} $ indexProd k l in
     cong (mapFst FS) $ splitOfIndexProdInverse k l

export
indexOfSplitProdInverse : {m, n : Nat} -> (f : Fin (m * n)) ->
                          uncurry (indexProd {m} {n}) (splitProd {m} {n} f) = f
indexOfSplitProdInverse {m = S _} f with (@@ splitSum f)
  indexOfSplitProdInverse {m = S _} f | (Left l ** eq) = rewrite eq in Calc $
    |~ indexSum (Left l)
    ~~ indexSum (splitSum f) ...( cong indexSum (sym eq) )
    ~~ f                     ...( indexOfSplitSumInverse f )
  indexOfSplitProdInverse f | (Right r ** eq) with (@@ splitProd r)
    indexOfSplitProdInverse f | (Right r ** eq) | ((p, q) ** eq2)
      = rewrite eq in rewrite eq2 in Calc $
        |~ indexProd (FS p) q
        ~~ shift n (indexProd p q)                   ...( Refl )
        ~~ shift n (uncurry indexProd (splitProd r)) ...( cong (shift n . uncurry indexProd) (sym eq2) )
        ~~ shift n r                                 ...( cong (shift n) (indexOfSplitProdInverse r) )
        ~~ indexSum (splitSum f)                     ...( sym (cong indexSum eq) )
        ~~ f                                         ...( indexOfSplitSumInverse f )


import Data.Vect

read_vect_len : (len : Nat) -> IO (Vect len String)
read_vect_len Z = pure []
read_vect_len (S k) = do
  x <- getLine
  xs <- read_vect_len k
  pure (x :: xs)

read_vect : IO (n ** Vect n String)
read_vect = do
  x <- getLine
  if (x == "")
    then pure (_ ** [])
    else do (_ ** xs) <- read_vect
            pure (_ ** (x :: xs))

zipInputs : IO ()
zipInputs = do
  putStrLn "1:"
  (len1 ** vec1) <- read_vect
  putStrLn "2:"
  (len2 ** vec2) <- read_vect
  case exactLength len1 vec2 of
    Nothing => putStrLn "Input lengths must be equal"
    Just vec2' => printLn (zip vec1 vec2')


data Elem : a -> List a -> Type where
  Here : Elem x (x :: xs)
  There : Elem x xs -> Elem x (y :: xs)

data Last : List a -> a -> Type where
  LastOne : Last [value] value
  LastCons : (prf : Last xs value) -> Last (x :: xs) value

not_in_nil : Last [] value -> Void
not_in_nil LastOne impossible
not_in_nil (LastCons _) impossible

not_last_one : (contra : (value = x) -> Void) -> Last [x] value -> Void
not_last_one contra LastOne = contra Refl
not_last_one _ (LastCons LastOne) impossible
not_last_one _ (LastCons (LastCons _)) impossible

not_last_cons : (contra : Last (x :: xs) value -> Void) ->
                   Last (y :: (x :: xs)) value -> Void
not_last_cons contra (LastCons prf) = contra prf

isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
isLast [] value = No not_in_nil
isLast [x] value = case decEq value x of
                        (Yes Refl) => Yes LastOne
                        (No contra) => No (not_last_one contra)
isLast (y :: (x :: xs)) value = case isLast (x :: xs) value of
                                     (Yes prf) => Yes (LastCons prf)
                                     (No contra) => No (not_last_cons contra)


import Data.Vect

insert : Ord elem => (x : elem) -> (sorted : Vect k elem) -> Vect (S k) elem
insert x [] = [x]
insert x (y :: xs) = case x < y of
                        False => y :: insert x xs
                        True => x :: y :: xs

ins_sort : Ord elem => Vect n elem -> Vect n elem
ins_sort [] = []
ins_sort (x :: xs) = let sorted = ins_sort xs in
                      insert x sorted

-- *vec_sort> ins_sort ['C', 'A', 'Z']
-- ['A', 'C', 'Z'] : Vect 3 Char
-- *vec_sort> ins_sort [3,2,9,7,6,5,8]
-- [2, 3, 5, 6, 7, 8, 9] : Vect 7 Integer


import Data.Nat
data FizzBuzzReturn =
  Fizz
  | Buzz
  | FizzBuzz
  | Normal Nat

Show FizzBuzzReturn where
  show Fizz = "fizz"
  show Buzz = "buzz"
  show FizzBuzz = "fizzbuzz"
  show (Normal x) = show x

partial fizzBuzzReturn: (x: Nat) -> FizzBuzzReturn
fizzBuzzReturn x with (modNat x (the Nat 3), modNat x (the Nat 5))
  fizzBuzzReturn x | (Z, Z) = FizzBuzz
  fizzBuzzReturn x | (Z, _) = Fizz
  fizzBuzzReturn x | (_, Z) = Buzz
  fizzBuzzReturn x | _ = Normal x

partial fizzBuzzReturnString: (x: Nat) -> String
fizzBuzzReturnString x = show(fizzBuzzReturn x)


module Main

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

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

main : IO ()
main = putStrLn $ show $ even $ sum [1,3,4,5,2]


module CommutativityOfAddition

%default total

sym_eq : x = y -> y = x
sym_eq Refl = Refl

tr_eq : x = y -> y = z -> x = z
tr_eq Refl Refl = Refl

congr : (P : a -> b) -> x = y -> P x = P y
congr f Refl = Refl

-- x = x + 0
sym_plus_z : {m : Nat} -> m = m + 0
sym_plus_z {m=Z} = Refl
-- sym_plus_z {m=(S k)} = congr S (sym_plus_z{m=k})
sym_plus_z {m=(S k)} = rewrite sym_plus_z{m=k} in Refl

-- S x = 1 + x
sym_plus_one_left : {m : Nat} -> S m = 1 + m
sym_plus_one_left = Refl

-- S x = x + 1
sym_plus_one_right : {m : Nat} -> S m = m + 1
sym_plus_one_right {m=Z} = Refl
sym_plus_one_right {m=(S k)} =
    rewrite sym_plus_one_right{m=k} in Refl

proof11 : {m : Nat} -> S m + m = S (m + m)
proof11 {m = Z}     = Refl
proof11 {m = (S k)} = Refl

proof12 : {m : Nat} -> {a : Nat} -> a + (S m) = S (a + m)
-- 0 + (S m) = S (0 + m)
proof12 {m=m} {a=Z} = Refl
proof12 {m=m} {a=(S k)} = rewrite proof12{m=m}{a=k} in Refl

-- S x + S x = S (S (x + x))
export
-- S (S x) + S (S x) = S (S (S S (x + x)))
sumSucc : {m : Nat} -> S m + S m = S (S (m + m))
-- -- S 0 + S 0 = S (S (0 + 0))
sumSucc {m=Z} = Refl
-- S (S k) + S (S k) = S (S ((S k) + (S k)))
sumSucc {m=m} = let rec = proof12{m=m}{a=m} -- (S m) + (S m) = S ((S m) + m)
             in rewrite rec
             in Refl

proof2 : {x: Nat} -> {y: Nat} -> S x + S y = S (S (x + y))
proof2 {x=Z} {y=Z}           = Refl
proof2 {x=Z} {y=(S k)}       = Refl
proof2 {x=(S k)}  {y=Z}      = rewrite proof2{x=k}{y=Z} in Refl
proof2 {x=(S kx)} {y=(S ky)} = rewrite proof2{x=kx}{y=(S ky)} in Refl

proof3 : {x, y: Nat} -> {y: Nat} -> S (x + y) = x + (S y)
proof3 {x=Z}{y=y} = Refl
proof3 {x=(S k)}{y=y} =      -- S (S k + y) = S k + (S y)
    let p = proof3{x=k}{y=y} --   S (k + y) = k + (S y)
    in congr S p
    -- rewrite proof3{x=k}{y=y} --   S (k + y) = k + (S y)
    -- in Refl                  --  (k + (S y) = k + (S y)
                                --  S (S k + y) = S (k + (S y))
    -- replace{P=\w => S (S k + y) = S w} (proof3{x=k}{y=y}) Refl{x=(S k + y)}

sym_plus : {x,y:Nat} -> x + y = y + x
sym_plus {x=Z}{y=Z}           = Refl
sym_plus {x=Z}{y=(S k)}       = sym_plus_z
sym_plus {x=(S k)}{y=Z}       = sym_eq sym_plus_z
-- sym_plus_z = 0 + x = x + 0
sym_plus {x=(S kx)}{y=(S ky)} =       --  S kx + y = y + S kx
    let p1 = sym_plus{x=kx}{y=(S ky)}    -- kx + y = y + kx
        p2 =  proof3{x=(S ky)}{y=kx} -- S (y + kx) = y + (S kx)
    in tr_eq (congr S p1) p2
-- proof3 : S (x + y) = x + (S y)


module Algebra.Semiring

import Data.Nat
import Syntax.PreorderReasoning

%default total

||| This interface is a witness that for a
||| numeric type `a` the axioms of a commutative semiring hold:
|||
||| 1. `a` is a commutative monoid under addition:
|||    1. `+` is associative: `k + (m + n) = (k + m) + n` for all `k,m,n : a`.
|||    2. `+` is commutative: `m + n = n + m` for all `m,n : a`.
|||    3. 0 is the additive identity: `n + 0 = n` for all `n : a`.
|||
||| 2. `a` is a commutative monoid under multiplication:
|||    1. `*` is associative: `k * (m * n) = (k * m) * n` for all `k,m,n : a`.
|||    2. `*` is commutative: `m * n = n * m` for all `m,n : a`.
|||    3. 1 is the multiplicative identity: `n * 1 = n` for all `n : a`.
|||
||| 3. Multiplication is distributive with respect to addition:
|||    `k * (m + n) = (k * m) + (k * n)` for all `k,m,n : a`.
|||
public export
interface Num a => Semiring a where
  ||| Addition is associative.
  0 plusAssociative : {k,m,n : a} -> k + (m + n) === (k + m) + n

  ||| Addition is commutative.
  0 plusCommutative : {m,n : a} -> m + n === n + m

  ||| 0 is the additive identity.
  0 plusZeroLeftNeutral : {n : a} -> 0 + n === n

  ||| Multiplication is associative.
  0 multAssociative : {k,m,n : a} -> k * (m * n) === (k * m) * n

  ||| Multiplication is commutative.
  0 multCommutative : {m,n : a} -> m * n === n * m

  ||| 1 is the multiplicative identity.
  0 multOneLeftNeutral : {n : a} -> 1 * n === n

  ||| Multiplication is distributive with respect to addition.
  0 leftDistributive : {k,m,n : a} -> k * (m + n) === (k * m) + (k * n)

  ||| Zero is an absorbing element of multiplication.
  0 multZeroLeftAbsorbs : {n : a} -> 0 * n === 0

--------------------------------------------------------------------------------
--          Proofs on Addition
--------------------------------------------------------------------------------

||| `n + 0 === n` for all `n : a`.
export
0 plusZeroRightNeutral : Semiring a => {n : a} -> n + 0 === n
plusZeroRightNeutral =
  Calc $
    |~ n + 0
    ~~ 0 + n ... plusCommutative
    ~~ n     ... plusZeroLeftNeutral

--------------------------------------------------------------------------------
--          Proofs on Multiplication
--------------------------------------------------------------------------------

||| `n * 1 === n` for all `n : a`.
export
0 multOneRightNeutral : Semiring a => {n : a} -> n * 1 === n
multOneRightNeutral =
  Calc $
    |~ n * 1
    ~~ 1 * n ... multCommutative
    ~~ n     ... multOneLeftNeutral

||| Zero is an absorbing element of multiplication.
export
0 multZeroRightAbsorbs : Semiring a => {n : a} -> n * 0 === 0
multZeroRightAbsorbs =
  Calc $
    |~ n * 0
    ~~ 0 * n ... multCommutative
    ~~ 0     ... multZeroLeftAbsorbs

||| Zero is an absorbing element of multiplication.
export
multZeroAbsorbs :  Semiring a
                => (m,n : a)
                -> Either (m === 0) (n === 0)
                -> m * n === 0
multZeroAbsorbs m n (Left rfl) =
  Calc $
    |~ m * n
    ~~ 0 * n ... cong (*n) rfl
    ~~ 0     ... multZeroLeftAbsorbs

multZeroAbsorbs m n (Right rfl) =
  Calc $
    |~ m * n
    ~~ m * 0 ... cong (m*) rfl
    ~~ 0     ... multZeroRightAbsorbs

||| Multiplication is distributive with respect to addition.
export
0 rightDistributive :  Semiring a
                  => {k,m,n : a}
                  -> (m + n) * k === m * k + n * k
rightDistributive =
  Calc $
    |~ (m + n) * k
    ~~ k * (m + n)       ... multCommutative
    ~~ (k * m) + (k * n) ... leftDistributive
    ~~ m * k + k * n     ... cong (+ k * n) multCommutative
    ~~ m * k + n * k     ... cong (m * k +) multCommutative

--------------------------------------------------------------------------------
--          Implementations
--------------------------------------------------------------------------------

export
Semiring Nat where
  plusAssociative = Nat.plusAssociative _ _ _
  plusCommutative = Nat.plusCommutative _ _
  plusZeroLeftNeutral = Nat.plusZeroLeftNeutral _
  multAssociative = Nat.multAssociative _ _ _
  multCommutative = Nat.multCommutative _ _
  multOneLeftNeutral = Nat.multOneLeftNeutral _
  leftDistributive = multDistributesOverPlusRight _ _ _
  multZeroLeftAbsorbs = Refl


module As

-- Test @
isS : Nat -> Maybe Nat
isS Z = Nothing
isS n@(S _) = Just n

-- Test @ under a constructor
hasS : List Nat -> Maybe Nat
hasS (Z::xs) = hasS xs
hasS (n@(S _)::xs) = Just n
hasS _ = Nothing

-- Test nested @s
isSS : Nat -> Maybe (Nat, Nat)
isSS n@(S m@(S _)) = Just (n,m)
isSS _ = Nothing

-- Test two @-patterns
same : Nat -> Nat -> Maybe Nat
same x@(S _) y@(S _) = Just $ x + y
same Z Z = Just 42
same _ _ = Nothing

namespace Main
  main : IO ()
  main = do printLn $ isS 0
            printLn $ isS 1
            printLn $ hasS [0,0,0]
            printLn $ hasS [0,1,2]
            printLn $ isSS 5
            printLn $ isSS 0
            printLn $ same 1 1
            printLn $ same 0 0
            printLn $ same 1 0


module Data.These

%default total

public export
data These a b = This a | That b | Both a b

public export
fromEither : Either a b -> These a b
fromEither = either This That

public export
fromThis : These a b -> Maybe a
fromThis (This a) = Just a
fromThis (That _) = Nothing
fromThis (Both a _) = Just a

public export
fromThat : These a b -> Maybe b
fromThat (This _) = Nothing
fromThat (That b) = Just b
fromThat (Both _ b) = Just b

public export
these : (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these l r lr (This a)   = l a
these l r lr (That b)   = r b
these l r lr (Both a b) = lr a b

public export
bimap : (f : a -> b) -> (g : c -> d) -> These a c -> These b d
bimap f g (This a)   = This (f a)
bimap f g (That b)   = That (g b)
bimap f g (Both a b) = Both (f a) (g b)

public export
(Show a, Show b) => Show (These a b) where
  showPrec d (This x)   = showCon d "This" $ showArg x
  showPrec d (That x)   = showCon d "That" $ showArg x
  showPrec d (Both x y) = showCon d "Both" $ showArg x ++ showArg y

public export
Functor (These a) where
  map = bimap id

public export
mapFst : (f : a -> b) -> These a c -> These b c
mapFst f = bimap f id

public export
bifold : Monoid m => These m m -> m
bifold (This a)   = a
bifold (That b)   = b
bifold (Both a b) = a <+> b

public export
bitraverse : Applicative f => (a -> f c) -> (b -> f d) -> These a b -> f (These c d)
bitraverse f g (This a)   = [| This (f a) |]
bitraverse f g (That b)   = [| That (g b) |]
bitraverse f g (Both a b) = [| Both (f a) (g b) |]


data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)

Functor Tree where
  map func Empty = Empty
  map func (Node left e right)
    = Node (map func left)
           (func e)
           (map func right)

Foldable Tree where
  foldr func acc Empty = acc
  foldr func acc (Node left e right)
    = let leftfold = foldr func acc left
          rightfold = foldr func leftfold right in
          func e rightfold


module Data.List.Views.Extra

import Data.List
import Data.List.Reverse
import Data.List.Views
import Data.Nat
import Data.List.Equalities

%default total

||| Proof that two numbers differ by at most one
public export
data Balanced : Nat -> Nat -> Type where
  BalancedZ   : Balanced Z Z
  BalancedL   : Balanced (S Z) Z
  BalancedRec : Balanced n m -> Balanced (S n) (S m)

%name Balanced bal, b

Uninhabited (Balanced Z (S k)) where
  uninhabited BalancedZ impossible
  uninhabited BalancedL impossible
  uninhabited (BalancedRec rec) impossible

export
balancedPred : Balanced (S x) (S y) -> Balanced x y
balancedPred (BalancedRec pred) = pred

export
mkBalancedEq : {n, m : Nat} -> n = m -> Balanced n m
mkBalancedEq {n = 0} Refl = BalancedZ
mkBalancedEq {n = (S k)} Refl = BalancedRec $ mkBalancedEq {n = k} Refl

export
mkBalancedL : {n, m : Nat} -> n = S m -> Balanced n m
mkBalancedL {m = 0} Refl = BalancedL
mkBalancedL {m = S k} Refl = BalancedRec (mkBalancedL Refl)

||| View of a list split into two halves
|||
||| The lengths of the lists are guaranteed to differ by at most one
public export
data SplitBalanced : List a -> Type where
  MkSplitBal
    : {xs, ys : List a}
    -> Balanced (length xs) (length ys)
    -> SplitBalanced (xs ++ ys)

private
splitBalancedHelper
  : (revLs : List a)
  -> (rs : List a)
  -> (doubleSkip : List a)
  -> (length rs = length revLs + length doubleSkip)
  -> SplitBalanced (reverse revLs ++ rs)
splitBalancedHelper revLs rs [] prf = MkSplitBal balancedLeftsAndRights
  where
    lengthsEqual : length rs = length revLs
    lengthsEqual =
      rewrite sym (plusZeroRightNeutral (length revLs)) in prf
    balancedLeftsAndRights : Balanced (length (reverse revLs)) (length rs)
    balancedLeftsAndRights =
      rewrite reverseLength revLs in
        rewrite lengthsEqual in
          mkBalancedEq Refl
splitBalancedHelper revLs [] (x :: xs) prf =
  absurd $
    the (0 = S (plus (length revLs) (length xs)))
      rewrite plusSuccRightSucc (length revLs) (length xs) in
        prf
splitBalancedHelper revLs (x :: rs) [lastItem] prf =
  rewrite appendAssociative (reverse revLs) [x] rs in
    rewrite sym (reverseCons x revLs) in
      MkSplitBal $
        the (Balanced (length (reverseOnto [x] revLs)) (length rs)) $
          rewrite reverseCons x revLs in
            rewrite lengthSnoc x (reverse revLs) in
              rewrite reverseLength revLs in
                rewrite lengthsEqual in
                  mkBalancedL Refl
  where
    lengthsEqual : length rs = length revLs
    lengthsEqual =
      cong pred $
        the (S (length rs) = S (length revLs)) $
          rewrite plusCommutative 1 (length revLs) in prf
splitBalancedHelper revLs (x :: oneFurther) (_ :: (_ :: twoFurther)) prf =
  rewrite appendAssociative (reverse revLs) [x] oneFurther in
    rewrite sym (reverseCons x revLs) in
      splitBalancedHelper (x :: revLs) oneFurther twoFurther $
        cong pred $
          the (S (length oneFurther) = S (S (plus (length revLs) (length twoFurther)))) $
          rewrite plusSuccRightSucc (length revLs) (length twoFurther) in
            rewrite plusSuccRightSucc (length revLs) (S (length twoFurther)) in
              prf

||| Covering function for the `SplitBalanced`
|||
||| Constructs the view in linear time
export
splitBalanced : (input : List a) -> SplitBalanced input
splitBalanced input = splitBalancedHelper [] input input Refl

||| The `VList` view allows us to recurse on the middle of a list,
||| inspecting the front and back elements simultaneously.
public export
data VList : List a -> Type where
  VNil : VList []
  VOne : VList [x]
  VCons : {x, y : a} -> {xs : List a} -> (rec : Lazy (VList xs)) -> VList (x :: xs ++ [y])

private
toVList
  : (xs : List a)
  -> SnocList ys
  -> Balanced (length xs) (length ys)
  -> VList (xs ++ ys)
toVList [] Empty BalancedZ = VNil
toVList [x] Empty BalancedL = VOne
toVList [] (Snoc x zs rec) prf =
  absurd $
    the (Balanced 0 (S (length zs))) $
      rewrite sym (lengthSnoc x zs) in prf
toVList (x :: xs) (Snoc y ys srec) prf =
  rewrite appendAssociative xs ys [y] in
    VCons $
      toVList xs srec $
        balancedPred $
          rewrite sym (lengthSnoc y ys) in prf

||| Covering function for `VList`
||| Constructs the view in linear time.
export
vList : (xs : List a) -> VList xs
vList xs with (splitBalanced xs)
  vList (ys ++ zs) | (MkSplitBal prf) = toVList ys (snocList zs) prf

||| Lazy filtering of a list based on a predicate.
public export
data LazyFilterRec : List a -> Type where
  Exhausted : (skip : List a) -> LazyFilterRec skip
  Found     : (skip : List a) -- initial non-matching elements
            -> (head : a)      -- first match
            -> Lazy (LazyFilterRec rest)
            -> LazyFilterRec (skip ++ (head :: rest))

||| Covering function for the LazyFilterRec view.
||| Constructs the view lazily in linear time.
total export
lazyFilterRec : (pred : (a -> Bool)) -> (xs : List a) -> LazyFilterRec xs
lazyFilterRec pred [] = Exhausted []
lazyFilterRec pred (x :: xs) with (pred x)
  lazyFilterRec pred (x :: xs) | True = Found [] x (lazyFilterRec pred xs)
  lazyFilterRec pred (x :: []) | False = Exhausted [x]
  lazyFilterRec pred (x :: rest@(_ :: xs)) | False = filterHelper [x] rest
    where
      filterHelper
        : (reverseOfSkipped : List a)
        -> {auto prf1 : NonEmpty reverseOfSkipped}
        -> (rest : List a)
        -> {auto prf2 : NonEmpty rest}
        -> LazyFilterRec (reverse reverseOfSkipped ++ rest)
      filterHelper revSkipped (y :: xs) with (pred y)
      filterHelper revSkipped (y :: xs) | True =
        Found (reverse revSkipped) y (lazyFilterRec pred xs)
      filterHelper revSkipped (y :: []) | False =
        rewrite sym (reverseOntoSpec [y] revSkipped) in
          Exhausted $ reverse (y :: revSkipped)
      filterHelper revSkipped (y :: (z :: zs)) | False =
        rewrite appendAssociative (reverse revSkipped) [y] (z :: zs) in
          rewrite sym (reverseOntoSpec [y] revSkipped) in
            filterHelper (y :: revSkipped) (z :: zs)


module Equal

-- Equality type

data Equal : x -> y -> Type where
  Reflexive : Equal a a

-- Simple examples

bool : Equal Bool Bool
bool = Reflexive

true : Equal True True
true = Reflexive

two : Equal 2 (1 + 1)
two = Reflexive

-- Helpers

transitive : Equal a b -> Equal b c -> Equal a c
transitive Reflexive Reflexive = Reflexive

symmetric : Equal a b -> Equal b a
symmetric Reflexive = Reflexive

congruent : (f : t -> x) -> Equal a b -> Equal (f a) (f b)
congruent f Reflexive = Reflexive

-- Stepping it up

plusZero : (n : Nat) -> Equal (plus n Z) n
plusZero Z = the (Equal Z Z) Reflexive
plusZero (S k) =
  let induction = plusZero k
  in congruent S induction

-- Built-in equality

plusZero' : (n : Nat) -> plus n Z = n
plusZero' Z = Refl
plusZero' (S k) =
  let induction = plusZero' k
  in ?plusZero'_2

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

Equal.plusZero'_2 = proof
  intros
  rewrite induction
  trivial


import Data.Vect

createEmpties : Vect n (Vect 0 elem)
createEmpties = replicate _ []

transposeHelper : (x : Vect n elem) ->
                 (xsTrans : Vect n (Vect len elem)) ->
                 Vect n (Vect (S len) elem)
transposeHelper [] [] = []
transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys

transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat [] = createEmpties
transposeMat (x :: xs) = let xsTrans = transposeMat xs in
                         transposeHelper x xsTrans


module Sub05Apply9x6

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqPostuProof

%default total
-- %language ElabReflection

-- 3(3x+2) --C[4,-4]--> 3x
export
apply9x6 : (Not . P) (S (S (plus (plus j j) j)))
  -> (m : Nat ** (LTE (S m) (S (S (plus (plus j j) j))), (Not . P) m))
apply9x6 {j} col = (j ** (lte9x6 j, c9x6To3x j col)) where
  lte9x6 : (j:Nat) -> LTE (S j) (S (S (plus (plus j j) j)))
  lte9x6 Z = (lteSuccRight . LTESucc) LTEZero
  lte9x6 (S j) = let lemma = lte9x6 j in
    rewrite (sym (plusSuccRightSucc j j)) in
    rewrite (sym (plusSuccRightSucc (plus j j) j)) in
      (lteSuccRight . lteSuccRight . LTESucc) lemma


-- see: http://docs.idris-lang.org/en/latest/tutorial/interp.html
-- module Interp

import Data.Vect
import Data.Fin

data Ty = TyInt | TyBool | TyFun Ty Ty

interpTy : Ty -> Type
interpTy TyInt       = Int
interpTy TyBool      = Bool
interpTy (TyFun A T) = interpTy A -> interpTy T

using (G:Vect n Ty)  -- the context
  -- `HasType i G T` is a proof that variable `i` in context `G` has type `T`
  data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where
    -- proof that the most recently defined variable is well-typed:
    Stop : HasType FZ (t :: G) t                       -- de-Brujin index 0
    Pop  : HasType k G t -> HasType (FS k) (u :: G) t  -- Pop Stop is index 1, ...

  data Expr : Vect n Ty -> Ty -> Type where
    Var : HasType i G t
          -> Expr G t
    Val : (x : Int)
          -> Expr G TyInt
    Lam : Expr (a :: G) t
          -> Expr G (TyFun a t)
    App : Expr G (TyFun a t)
          -> Expr G a
          -> Expr G t
    Op  : (interpTy a -> interpTy b -> interpTy c) ->
          Expr G a -> Expr G b
          -> Expr G c
    If  : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a)
          -> Expr G a

  data Env : Vect n Ty -> Type where
    Nil   : Env Nil
    (::)  : interpTy a -> Env G -> Env (a :: G)

  -- given a proof that a variable if defined in the context,
  --   we can produce a value from the environment:
  lookup : HasType i G t -> Env G -> interpTy t
  lookup Stop    (x :: xs) = x
  lookup (Pop k) (x :: xs) = lookup k xs

  interp : Env G -> Expr G t -> interpTy t
  interp env (Var i)      = lookup i env
  interp env (Val x)      = x
  interp env (Lam sc)     = \x => interp (x :: env) sc
  interp env (App f s)    = (interp env f) (interp env s)
  interp env (Op op x y)  = op (interp env x) (interp env y)
  interp env (If cnd thn els)
                          = if interp env cnd
                            then interp env thn
                            else interp env els

  succ : Expr G (TyFun TyInt TyInt)
  succ = Lam (Op (+) (Var Stop) (Val 1))

  add : Expr G (TyFun TyInt (TyFun TyInt TyInt)) -- \x.\y.y + x
  add = Lam (Lam (Op (+) (Var Stop) (Var (Pop Stop))))
  -- `interp [] (App (App add (Val 2)) (Val 2))` gives `4 : Int`

  iszero : Expr G (TyFun TyInt TyBool)
  iszero = Lam (Op (==) (Var Stop) (Val 0))

  -- `interp [] (App fact (Val 4))` gives `24 : Int`
  fact : Expr G (TyFun TyInt TyInt)
  fact = Lam (If (App iszero (Var Stop))
                 (Val 1)
                 (Op (*) (Var Stop)
                         (App fact (Op (-) (Var Stop) (Val 1)))))

main : IO ()
main = do
  putStr "Enter a number: "
  n <- getLine
  printLn (interp [] fact (cast n))


module Idris.Codegen.ExtSTG.SemiDecEq

public export
interface SemiDecEq t where
  semiDecEq : (x : t) -> (y : t) -> Maybe (x = y)

export
SemiDecEq Nat where
  semiDecEq Z      Z      = Just Refl
  semiDecEq (S n1) (S n2) = do
    Refl <- semiDecEq n1 n2
    Just Refl
  semiDecEq _      _      = Nothing

export
SemiDecEq a => SemiDecEq (List a) where
  semiDecEq []        []        = Just Refl
  semiDecEq (x :: xs) (y :: ys) = do
    Refl <- semiDecEq x y
    Refl <- semiDecEq xs ys
    Just Refl
  semiDecEq _ _ = Nothing


module AOC.Day.Three

import AOC.Solution
import Data.Vect
import Data.String
import Data.Nat

%default total

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

data Bit : Type where
  Low : Bit
  High : Bit

Binary : (n : Nat) -> Type
Binary n = Vect n Bit

InputType : Type
InputType = (m ** List (Binary m))

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

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

-- Could be more efficient with fold and cons but eh.
[BinaryShow] Show (Binary n) where
  show [] = ""
  show (x :: xs) = show x ++ show @{BinaryShow} xs

Cast Bit Nat where
  cast Low = 0
  cast High = 1

Cast Bit Integer where
  cast x = the Integer (cast (the Nat (cast x)))

Cast Nat (Maybe Bit) where
  cast 0 = Just Low
  cast 1 = Just High
  cast _ = Nothing

Cast Bool Bit where
  cast False = Low
  cast True  = High

Cast (Binary n) Nat where
  cast = foldl (\acc, x => acc * 2 + x) 0 . map cast

Cast (Binary n) Integer where
  cast x = the Integer (cast (the Nat (cast x)))

----------------------------------------------------------------------------
-- Helper Functions --------------------------------------------------------
----------------------------------------------------------------------------

countBit : Bit -> Integer -> Integer
countBit Low x = x - 1
countBit High x = x + 1

moreOf : {n : Nat} -> List (Binary n) -> Vect n Integer
moreOf {n} list = foldr (\x, acc => zipWith countBit x acc) (replicate n 0) list

mostCommon : Vect n Integer -> Binary n
mostCommon = map (cast . (> 0))

leastCommon : Vect n Integer -> Binary n
leastCommon = map (cast . (< 0))

----------------------------------------------------------------------------
-- Solutions ---------------------------------------------------------------
----------------------------------------------------------------------------

part1 : InputType -> String
part1 (m ** list) = show $ (cast . mostCommon $ mf) * (cast . leastCommon $ mf)
  where
    mf : Vect m Integer
    mf = moreOf list

----------------------------------------------------------------------------
-- Parsing Helper Functions ------------------------------------------------
----------------------------------------------------------------------------

toBinaryDep' : (s : List Char) -> Maybe (n ** Binary n)
toBinaryDep' [] = Just (0 ** [])
toBinaryDep' ('0' :: str) = (toBinaryDep' str) >>= (\(n ** bin) => Just $ (S n ** Low :: bin))
toBinaryDep' ('1' :: str) = (toBinaryDep' str) >>= (\(n ** bin) => Just $ (S n ** High :: bin))
toBinaryDep' _ = Nothing

toBinaryDep : (s : String) -> Maybe (n ** Binary n)
toBinaryDep s = toBinaryDep' (unpack s)

-- Stolen from https://github.com/jumper149/AoC2021/blob/main/03/src/Main.idr
exactLengths : (len : Nat) -> Traversable t => t (n ** Binary n) -> Maybe (t (Binary len))
exactLengths len xs = traverse (\ x => exactLength len x.snd) xs

-- I thought one could define validateBinaryList recursively without
-- exactLengths, but while that compiles, it results in returning Nothing
-- always. Not precisely sure which Nothing either (from the recursive call or
-- from the call to exactLength).
validateBinaryList : List (n ** Binary n) -> Maybe (InputType)
validateBinaryList [] = Just (0 ** [])
validateBinaryList ((len ** bin) :: ys) = do
  list <- exactLengths len ys
  pure (len ** bin :: list)

----------------------------------------------------------------------------
-- Interface for input/output ----------------------------------------------
----------------------------------------------------------------------------

parser : String -> Maybe (InputType)
parser = join . map validateBinaryList . sequence . map toBinaryDep . lines

export
day3 : (inputType ** AOCSolution inputType)
day3 = solutionToDP (MkAOCSolution {
    day = 3
  , parser = parser
  , part1 = part1
  , part2 = \x => "part2"
  })


module FirSigned

import ClosedInt
import Synchronous

import Data.Vect
import Data.ZZ
import Data.Bits

%access export
%default total

-- The Vect implementation of Foldable breaks a proof here...
-- Let's redefine sum for now without using fold
%hide sum
sum :  Num a => Vect n a -> a
sum [] = 0
sum (x::xs) = x + sum xs

||| Combinatorial dot product over `ClosedInt`s
dotProd : (ws : Vect j ZZ)
        -> Vect j (ClosedInt n m)
        -> ClosedInt (sum $ map (multLo n m) ws)
                     (sum $ map (multHi n m) ws)
dotProd []        []        = zeros
dotProd (w :: ws) (x :: xs) = add (multConst x w) (dotProd ws xs)

||| Synchronous FIR over `ClosedInt`s
fir : (ws : Vect j ZZ)
   -> Stream (ClosedInt n m)
   -> Stream (ClosedInt (sum $ map (multLo n m) ws)
                        (sum $ map (multHi n m) ws))
fir {j} ws x = liftA (dotProd ws) (window j zeros x)

-- TODO Consider a wrapper for this with Signed

||| Example of simulating `fir`
main : IO ()
main = do let dut = fir [1,-1,2]
          let inp = map (saturate {n=0} {m=6}) $ counterFrom 0 {ty=ZZ}
          let out = take 5 $ simulate dut inp
          putStrLn $ show out

-- Local Variables:
-- idris-load-packages: ("contrib")
-- End:


-- Picture.idr
--
-- Demonstraters recursive data types

import Shape

||| Represents a picture with multiple shapes
public export
data Picture = Primitive Shape
             | Combine Picture Picture
             | Rotate Double Picture
             | Translate Double Double Picture

-- %name Shape shape, shape1, shape2
%name Picture pic, pic1, pic2

-- a test picture
rectangle : Picture
rectangle = Primitive (Rectangle 20 10)

circle : Picture
circle = Primitive (Circle 5)

triangle : Picture
triangle = Primitive (Triangle 10 10)

testPicture : Picture
testPicture = Combine (Translate 5 5 rectangle)
              (Combine (Translate 35 5 circle)
              (Translate 15 25 triangle))

||| Calculates the sum area of all shapes in a picture
export
pictureArea : Picture -> Double
pictureArea (Primitive shape) = area shape
pictureArea (Combine pic pic1) = pictureArea pic + pictureArea pic1
pictureArea (Rotate x pic) = pictureArea pic
pictureArea (Translate x y pic) = pictureArea pic