module Data.Matrix.Structural

-- For structural lemmas involving matrix operations
import Control.Algebra
import Control.Algebra.VectorSpace -- definition of module
import Classes.Verified -- definition of verified algebras other than modules
import Data.Matrix
import Data.Matrix.Algebraic -- module instances; from Idris 0.9.20
import Data.Matrix.AlgebraicVerified

import Data.Vect.Structural

%default total

transposeIndexChariz : {xs : Matrix n m a} -> index k $ transpose xs = getCol k xs
transposeIndexChariz {xs=[]} {k} = indexReplicateChariz
transposeIndexChariz {xs=x::xs} {k} = trans zipWithEntryChariz $ vectConsCong _ _ _ transposeIndexChariz

transposeNHead: with Data.Vect ( head $ transpose xs = map head xs )
transposeNHead = trans (sym indexFZIsheadValued) $ trans transposeIndexChariz $ extensionalEqToMapEq (\xs => indexFZIsheadValued {xs=xs}) _

transposeIndicesChariz : {xs : Matrix n m a} -> (i : Fin n) -> (j : Fin m) -> indices j i $ transpose xs = indices i j xs
transposeIndicesChariz i j = trans (cong {f=index i} transposeIndexChariz) indexMapChariz

transposeIsInvolution : with Data.Vect ( transpose $ transpose xs = xs )
transposeIsInvolution {xs} = vecIndexwiseEq (\i => vecIndexwiseEq (\j => trans (transposeIndicesChariz j i) $ transposeIndicesChariz i j))

transposeNTail : with Data.Vect ( transpose $ tail $ transpose xs = map tail xs )
transposeNTail {xs} = vecIndexwiseEq $ \i => vecIndexwiseEq $ \j => trans (transposeIndicesChariz j i)
	$ trans (cong {f=(index i) . (index $ FS j)} $ sym $ headtails $ transpose xs)
	$ trans (transposeIndicesChariz i (FS j))
	$ trans (cong {f=index $ FS j} $ headtails $ index i xs)
	$ sym $ cong {f=index j} indexMapChariz

vecMatMultIsTransposeVecMult : Ring a => (v : Vect n a) -> (xs : Matrix n m a) -> v <\> xs = (transpose xs) </> v
vecMatMultIsTransposeVecMult v xs = Refl

matVecMultIsVecTransposeMult : Ring a => (v : Vect m a) -> (xs : Matrix n m a) -> xs </> v = v <\> (transpose xs)
matVecMultIsVecTransposeMult v xs = sym $ trans (vecMatMultIsTransposeVecMult v $ transpose xs) $ cong {f=(</> v)} $ transposeIsInvolution {xs=xs}

headVecMatMultChariz : Ring a => {xs : Matrix _ (S _) a} -> head $ v<\>xs = v <:> (getCol FZ xs)
headVecMatMultChariz {v} {xs} = trans (sym $ indexFZIsheadValued {xs=v<\>xs})
	$ trans (indexMapChariz {k=FZ} {f=(v<:>)} {xs=transpose xs})
	$ cong {f=(v<:>)} $ transposeIndexChariz {k=FZ} {xs=xs}

matMultIndicesChariz : Ring a => {l : Matrix _ _ a} -> {r : Matrix _ _ a} -> indices i j (l<>r) = (index i l)<:>(getCol j r)
matMultIndicesChariz {l} {r} {i} {j} = trans (cong {f=index j} $ indexMapChariz {f=(<\>r)}) $ trans (indexMapChariz {f=((index i l)<:>)}) $ cong {f=((Vect.index i l)<:>)} transposeIndexChariz

-- But basically from (map) being a verifiable functor.
leadingElemExtensionFirstColReplicate : (r : a) -> getCol FZ $ map (r::) xs = replicate _ r
leadingElemExtensionFirstColReplicate {xs=[]} r = Refl
leadingElemExtensionFirstColReplicate {xs=x::xs} r = vecHeadtailsEq Refl $ leadingElemExtensionFirstColReplicate r

-- But basically from (map) being a verifiable functor.
leadingElemExtensionColFSId : getCol (FS i) $ map (r::) xs = getCol i xs
leadingElemExtensionColFSId {xs} {r} {i} = trans (composeUnderMap xs (index $ FS i) (r::)) $ the (map ((index $ FS i) . (r::)) xs = map (index i) xs) $ extensionalEqToMapEq (\v => Refl) xs

leadingElemExtensionAsZipWithCons : map (r::) xs = Vect.zipWith Vect.(::) (replicate _ r) xs
leadingElemExtensionAsZipWithCons {xs=[]} = Refl
leadingElemExtensionAsZipWithCons {xs=x::xs} = vecHeadtailsEq Refl leadingElemExtensionAsZipWithCons

nullcolExtensionEq : Monoid a => {xs : Matrix n (S predm) a} -> (getCol FZ xs=Algebra.neutral) -> map ((Algebra.neutral)::) $ map Vect.tail xs = xs
nullcolExtensionEq {xs} prColNeut = trans leadingElemExtensionAsZipWithCons
	-- = zipWith (::) Algebra.neutral $ map tail xs
	$ trans (cong {f=zipWith (::) Algebra.neutral} $ sym $ transposeNTail)
	-- = zipWith (::) Algebra.neutral $ transpose $ tail $ transpose xs
	-- === transpose $ Algebra.neutral :: (tail $ transpose xs)
	$ trans (cong {f=transpose}
		$ trans (vecHeadtailsEq
			(trans (sym prColNeut)
				-- Algebra.neutral = getCol FZ xs
				$ trans (sym transposeIndexChariz)
				-- = index FZ $ transpose xs
				$ indexFZIsheadValued)
			Refl)
		-- Algebra.neutral :: (tail $ transpose xs) = head _ :: tail _
		$ sym $ headtails $ transpose xs)
	-- = transpose $ transpose xs
	transposeIsInvolution
	-- = xs

{-
Theorems about the module (Matrix n m a) over a ring (a):
* Compatibility between the Algebra.neutral of the ring (a) and of (Matrix n m a) as a module under (index).
-}

indexNeutralIsNeutral2D : Ring a => (k : Fin n) -> index k $ Algebra.neutral {a=Matrix n m a} = Algebra.neutral
indexNeutralIsNeutral2D FZ = Refl
indexNeutralIsNeutral2D (FS k) = indexNeutralIsNeutral2D k


module Main

-- base
import Control.Monad.State
import Data.List
import System.File

-- contrib
import Data.SortedMap
import Text.Lexer
import Text.Lexer.Core
import Text.Parser
import Text.Parser.Core

namespace Input
  data Token = TComma
             | TUnknown
             | TNat Nat

  readDigit : Char -> Maybe Nat
  readDigit '0' = Just 0
  readDigit '1' = Just 1
  readDigit '2' = Just 2
  readDigit '3' = Just 3
  readDigit '4' = Just 4
  readDigit '5' = Just 5
  readDigit '6' = Just 6
  readDigit '7' = Just 7
  readDigit '8' = Just 8
  readDigit '9' = Just 9
  readDigit _ = Nothing

  combineReversedDigits : List Nat -> Nat
  combineReversedDigits [] = 0
  combineReversedDigits (n :: ns) = n + 10 * combineReversedDigits ns

  reverseNaturalGrammar : Grammar Char False Nat
  reverseNaturalGrammar =
    map combineReversedDigits $ many $ terminal "Can't parse digit" readDigit

  readTNat : String -> Token
  readTNat str = do
    let eithNat = parse reverseNaturalGrammar $ unpack $ reverse str
    case eithNat of
         Left _ => TUnknown
         Right (nat,_) => TNat nat

  toTokenData : String -> List (TokenData Token)
  toTokenData str = fst $
                    [ (is ',' , const TComma)
                    , (digits , readTNat)
                    ] `lex` str

  export
  readInput : String -> List Nat
  readInput str = reverse $ toNatList $ map tok $ toTokenData str where
    toNatList : List Token -> List Nat
    toNatList [] = []
    toNatList (TComma :: xs) = toNatList xs
    toNatList (TUnknown :: xs) = toNatList xs
    toNatList (TNat n :: xs) = n :: toNatList xs

namespace Part1
  findIndex : Eq a => a -> List a -> Maybe Nat
  findIndex y [] = Nothing
  findIndex y (x :: xs) =
    if x == y
       then Just 0
       else (1 +) <$> findIndex y xs

  nextNumber : List Nat -> Nat
  nextNumber [] = 0
  nextNumber (x :: xs) =
    case findIndex x xs of
         Nothing => 0
         Just n => 1 + n

  turn : List Nat -> List Nat
  turn ns = nextNumber ns :: ns

  doTimes : Nat -> (a -> a) -> a -> a
  doTimes Z _ x = x
  doTimes (S k) f x = doTimes k f $ f x

  minus : Nat -> Nat -> Maybe Nat
  minus Z Z = Just Z
  minus (S k) Z = Just $ S k
  minus Z (S k) = Nothing
  minus (S k) (S k') = k `minus` k'

  times : List Nat -> Maybe Nat
  times ns = 2020 `minus` length ns

  export
  turns : List Nat -> Maybe Nat
  turns ns = (doTimes <$> times ns <*> pure turn <*> pure ns) >>= head'

  times2 : List Nat -> Maybe Nat
  times2 ns = 30000000 `minus` length ns

namespace Part2
  record Game where
    constructor MkGame
    lookupTable : SortedMap Nat Nat
    lastNumber : Nat
    counter : Nat

  Show Game where
    show (MkGame lookupTable lastNumber counter) =
      "Game { lookupTable = " ++ show lookupTable
            ++ ", lastNumber = " ++ show lastNumber
            ++ ", counter = " ++ show counter
            ++ " }"

  scriptedTurn : Monad m => Nat -> StateT Game m ()
  scriptedTurn n = do
    game <- get
    let newLookupTable = (1 +) <$> insert game.lastNumber 0 game.lookupTable
        newCounter = 1 + game.counter
    put $ record { lookupTable = newLookupTable
                 , lastNumber = n
                 , counter = newCounter
               } game

  turn : Monad m => StateT Game m ()
  turn = do
    game <- get
    let mbDistance = lookup game.lastNumber game.lookupTable
        newLookupTable = (1 +) <$> insert game.lastNumber 0 game.lookupTable
        newCounter = 1 + game.counter
    put $ record { lookupTable = newLookupTable
                 , lastNumber = case mbDistance of
                                     Nothing => 0
                                     Just n => n
                 , counter = newCounter
               } game

  log : StateT Game IO ()
  log = do
    game <- get
    if natToInteger game.counter `mod` 10000 == 0
       then lift $ putStrLn $ show $ game.lookupTable
       else pure ()

  export
  turns : Nat -> StateT Game IO ()
  turns n = do
    n' <- gets counter
    --log
    if n == n'
       then do
         game <- get
         lift $ putStrLn $ show $ game.lastNumber
       else do
         turn
         turns n

  export
  initialGame : List Nat -> Game
  initialGame xs = removeWrongZero $ execState scriptedTurns startVal where
    removeWrongZero : Game -> Game
    removeWrongZero (MkGame lookupTable lastNumber counter) =
      MkGame newLookupTable lastNumber counter where
        newLookupTable : SortedMap Nat Nat
        newLookupTable = case lookup 0 lookupTable of
                              Nothing => lookupTable
                              Just n => if n == counter
                                           then delete 0 lookupTable
                                           else lookupTable
    scriptedTurns : Monad m => StateT Game m ()
    scriptedTurns = sequence_ $ map scriptedTurn $ xs
    startVal : Game
    startVal = MkGame empty 0 0 -- TODO: doesn't work unless the first number is 0; get's fixed in removeWrongZero

main : IO ()
main = do
  inputData <- readFile "./data"
  case inputData of
       Left err => print err
       Right dat => do
         let startingNumbers = readInput dat
         --traverse_ (putStrLn . show) $ turns startingNumbers
         let startingNumbers' = reverse startingNumbers
             maxCounter = 30000000
         _ <- runStateT (turns 300000) (initialGame startingNumbers')
         pure ()
  pure ()


-- -------------------------------------------------------------- [ Lens.idr ]
-- Description : Idris port of Control.Lens
-- Copyright   : (c) Huw Campbell
-- --------------------------------------------------------------------- [ EOH ]
module Control.Lens.Maths
import Control.Lens.Types
import Control.Lens.Setter

%default total

infixr 4 +~
public export
(+~) : Num a => Setter s t a a -> a -> s -> t
l +~ n = over l (+ n)

infixr 4 *~
public export
(*~) : Num a => Setter s t a a -> a -> s -> t
l *~ n = over l (* n)

infixr 4 -~
public export
(-~) : (Neg a, Num a) => Setter s t a a -> a -> s -> t
l -~ n = over l (\x => x - n)

infixr 4 //~
public export
(//~) : Fractional a => Setter s t a a -> a -> s -> t
l //~ n = over l (/ n)

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


parameters (x : Nat, y : Nat)
  add : Nat
  add = x + y


module Main

import Control.Monad.State
import Data.Fin
import Lightyear
import Lightyear.Char
import Lightyear.Position
import Lightyear.Strings as LS

-- data structures

data Seat = NoSeat
          | EmptySeat
          | OccupiedSeat

Eq Seat where
  (==) NoSeat NoSeat = True
  (==) NoSeat EmptySeat = False
  (==) NoSeat OccupiedSeat = False
  (==) EmptySeat NoSeat = False
  (==) EmptySeat EmptySeat = True
  (==) EmptySeat OccupiedSeat = False
  (==) OccupiedSeat NoSeat = False
  (==) OccupiedSeat EmptySeat = False
  (==) OccupiedSeat OccupiedSeat = True

Show Seat where
  show NoSeat = "NoSeat"
  show EmptySeat = "EmptySeat"
  show OccupiedSeat = "OccupiedSeat"

data WaitingArea : Nat -> Nat -> Type where
  MkWaitingArea : Vect y (Vect x Seat) -> WaitingArea x y

Eq (WaitingArea x y) where
  (==) (MkWaitingArea a) (MkWaitingArea b) = a == b

Show (WaitingArea x y) where
  show (MkWaitingArea seats) = show "WaitingArea " ++ show seats

record Coordinate (x : Nat) (y : Nat) where
  constructor MkCoordinate
  xCoord : Fin x
  yCoord : Fin y

Show (Fin n) where
  show {n=n} fin = "Fin " ++ show n ++ " " ++ show (finToNat fin)

Show (Coordinate x y) where
  show (MkCoordinate xCoord yCoord) = show "Coordinate "  ++ show xCoord ++ " " ++ show yCoord

-- parsing

pSeat : Parser Seat
pSeat = do
  s <- oneOf ".L#"
  pure $ case s of
              '.' => NoSeat
              'L' => EmptySeat
              '#' => OccupiedSeat

pLine : Parser (Vect x Seat)
pLine {x=n} = ntimes n pSeat <* newline

pData : Parser (Vect y (Vect x Seat))
pData {y=n} = ntimes n pLine <* eof

parseCountX : String -> Either String Nat
parseCountX = LS.parse $ (Prelude.Nat.pred . colNo) <$> (many pSeat *> getPosition)

parseCountY : String -> Either String Nat
parseCountY = LS.parse $ (Prelude.Nat.pred . lineNo) <$> (many ((many pSeat) <* newline) *> getPosition)

parseCountXY : String -> Either String (Nat,Nat)
parseCountXY str = do
  x <- parseCountX str
  y <- parseCountY str
  pure (x,y)

parseWaitingArea : (x : Nat) -> (y : Nat) -> String -> Either String (WaitingArea x y)
parseWaitingArea x y str = MkWaitingArea <$> LS.parse pData str

-- updating

-- Helper function for adjacentCoordinates.
-- This function looks complicated to cover n = 1, because succ and pred are annoying then.
adjacentFin : Fin n -> List (Fin n)
adjacentFin {n = Z} _ impossible
adjacentFin {n = S Z} FZ = []
adjacentFin {n = S Z} (FS _) impossible
adjacentFin FZ = [ FZ, succ FZ ]
adjacentFin (FS x) with ((FS x) == Data.Fin.last)
  adjacentFin (FS x) | False = [ pred (FS x), FS x, succ (FS x) ]
  adjacentFin (FS x) | True = [ pred (FS x), FS x ]

adjacentCoordinates : Coordinate x y -> List (Coordinate x y)
adjacentCoordinates (MkCoordinate xCoord yCoord) =
  [ MkCoordinate x y | x <- adjacentFin xCoord, y <- adjacentFin yCoord, x /= xCoord || y /= yCoord ]

getSeat : WaitingArea x y -> Coordinate x y -> Seat
getSeat (MkWaitingArea seats) (MkCoordinate xCoord yCoord) =
  index xCoord $ index yCoord seats

newSeat : WaitingArea x y -> Coordinate x y -> Seat
newSeat waitingArea coord = case oldSeat of
  NoSeat => NoSeat
  EmptySeat => if 0 == length occupiedNeighbors
                  then OccupiedSeat
                  else EmptySeat
  OccupiedSeat => if 4 <= length occupiedNeighbors
                     then EmptySeat
                     else OccupiedSeat
where
  oldSeat = getSeat waitingArea coord
  occupiedNeighbors : List Seat
  occupiedNeighbors = filter (== OccupiedSeat) $ getSeat waitingArea <$> adjacentCoordinates coord

allFins : Vect n (Fin n)
allFins {n=n} with (n)
  allFins {n=n} | Z = []
  allFins {n=n} | (S k) = FZ :: map FS allFins

allCoordinates : Vect y (Vect x (Coordinate x y))
allCoordinates = row <$> allFins where
  row y = MkCoordinate <$> allFins <*> pure y

updateWaitingArea : WaitingArea x y -> WaitingArea x y
updateWaitingArea waitingArea = MkWaitingArea $ map (newSeat waitingArea) <$> allCoordinates

-- updating (part 2)

data Direction = N
               | NE
               | E
               | SE
               | S
               | SW
               | W
               | NW

nextCoordInDirection : Coordinate x y -> Direction -> Maybe (Coordinate x y)
nextCoordInDirection {x=xx} {y=yy} (MkCoordinate x y) N = do
  newY <- integerToFin (finToInteger y + 1) yy
  pure $ MkCoordinate x newY
nextCoordInDirection {x=xx} {y=yy} (MkCoordinate x y) NE = do
  newY <- integerToFin (finToInteger y + 1) yy
  newX <- integerToFin (finToInteger x + 1) xx
  pure $ MkCoordinate newX newY
nextCoordInDirection {x=xx} {y=yy} (MkCoordinate x y) E = do
  newX <- integerToFin (finToInteger x + 1) xx
  pure $ MkCoordinate newX y
nextCoordInDirection {x=xx} {y=yy} (MkCoordinate x y) SE = do
  newY <- integerToFin (finToInteger y - 1) yy
  newX <- integerToFin (finToInteger x + 1) xx
  pure $ MkCoordinate newX newY
nextCoordInDirection {x=xx} {y=yy} (MkCoordinate x y) S = do
  newY <- integerToFin (finToInteger y - 1) yy
  pure $ MkCoordinate x newY
nextCoordInDirection {x=xx} {y=yy} (MkCoordinate x y) SW = do
  newY <- integerToFin (finToInteger y - 1) yy
  newX <- integerToFin (finToInteger x - 1) xx
  pure $ MkCoordinate newX newY
nextCoordInDirection {x=xx} {y=yy} (MkCoordinate x y) W = do
  newX <- integerToFin (finToInteger x - 1) xx
  pure $ MkCoordinate newX y
nextCoordInDirection {x=xx} {y=yy} (MkCoordinate x y) NW = do
  newY <- integerToFin (finToInteger y + 1) yy
  newX <- integerToFin (finToInteger x - 1) xx
  pure $ MkCoordinate newX newY

getNextSeatInDirection : WaitingArea x y -> Coordinate x y -> Direction -> Maybe Seat
getNextSeatInDirection waitingArea coord dir =
  getSeat waitingArea <$> nextCoordInDirection coord dir

isNextSeatInDirectionOccupied : WaitingArea x y -> Coordinate x y -> Direction -> Bool
isNextSeatInDirectionOccupied waitingArea coord dir with (getNextSeatInDirection waitingArea coord dir)
  isNextSeatInDirectionOccupied waitingArea coord dir | Nothing = False
  isNextSeatInDirectionOccupied waitingArea coord dir | (Just NoSeat) with (nextCoordInDirection coord dir)
    isNextSeatInDirectionOccupied waitingArea coord dir | (Just NoSeat) | Nothing = False -- actually impossible
    isNextSeatInDirectionOccupied waitingArea coord dir | (Just NoSeat) | (Just nextCoord) =
      isNextSeatInDirectionOccupied waitingArea nextCoord dir
  isNextSeatInDirectionOccupied waitingArea coord dir | (Just EmptySeat) = False
  isNextSeatInDirectionOccupied waitingArea coord dir | (Just OccupiedSeat) = True

countNextOccupiedSeats : WaitingArea x y -> Coordinate x y -> Nat
countNextOccupiedSeats waitingArea coord =
  length $ filter id $ isNextSeatInDirectionOccupied waitingArea coord <$> [N, NE, E, SE, S, SW, W, NW]

newSeat2 : WaitingArea x y -> Coordinate x y -> Seat
newSeat2 waitingArea coord = case oldSeat of
  NoSeat => NoSeat
  EmptySeat => if 0 == occupiedNeighbors
                  then OccupiedSeat
                  else EmptySeat
  OccupiedSeat => if 5 <= occupiedNeighbors
                     then EmptySeat
                     else OccupiedSeat
where
  oldSeat = getSeat waitingArea coord
  occupiedNeighbors : Nat
  occupiedNeighbors = countNextOccupiedSeats waitingArea coord

updateWaitingArea2 : WaitingArea x y -> WaitingArea x y
updateWaitingArea2 waitingArea = MkWaitingArea $ map (newSeat2 waitingArea) <$> allCoordinates

-- counting

countOccupiedSeats : WaitingArea x y -> Nat
countOccupiedSeats (MkWaitingArea seats) =
  length $ elemIndices OccupiedSeat $ concat seats

-- main

upd : StateT (WaitingArea x y) IO ()
upd = do
  wa <- get
  lift $ print $ countOccupiedSeats wa
  lift $ putStr "\n"
  --let waNew = updateWaitingArea wa
  let waNew = updateWaitingArea2 wa
  put waNew
  upd

main : IO ()
main = do
  inputData' <- readFile "./data"
  case inputData' of
       Right inputData => case parseCountXY inputData of
                               Right (x,y) => case parseWaitingArea x y inputData of
                                                   Right w0 => do
                                                     runStateT upd w0
                                                     pure ()


> module SequentialDecisionProblems.applications.Main

> import Data.Fin
> import Data.List
> import Data.List.Quantifiers
> import Data.So
> import Control.Isomorphism
> import Effects
> import Effect.Exception
> import Effect.StdIO

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.FullTheory
> import SequentialDecisionProblems.Utils
> import SequentialDecisionProblems.FastStochasticDefaults
> import SequentialDecisionProblems.CoreTheoryOptDefaults
> import SequentialDecisionProblems.FullTheoryOptDefaults

> import SequentialDecisionProblems.applications.FreezeOrIncrease
> import SequentialDecisionProblems.applications.GoodOrBad

> import FastSimpleProb.SimpleProb
> import FastSimpleProb.BasicOperations
> import FastSimpleProb.BasicProperties
> import FastSimpleProb.MonadicOperations
> import FastSimpleProb.MonadicProperties
> import FastSimpleProb.Measures
> import FastSimpleProb.MeasuresProperties
> import Sigma.Sigma
> import Sigma.Operations
> import Sigma.Properties
> import Nat.LTProperties
> import Double.Predicates
> import NonNegDouble.NonNegDouble
> import NonNegDouble.Constants
> import NonNegDouble.BasicOperations
> import NonNegDouble.Operations
> import NonNegDouble.Properties
> import NonNegDouble.Predicates
> import NonNegDouble.LTEProperties
> import NonNegDouble.Measures
> import NonNegDouble.MeasureProperties
> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Unique.Predicates
> import Decidable.Predicates
> import LocalEffect.Exception
> import LocalEffect.StdIO
> import Fin.Operations
> import Fraction.Fraction
> import Fraction.Normal
> import Nat.Positive
> import List.Operations
> import Unit.Properties

> -- %default total
> %auto_implicits off

> -- %logging 5

* Introduction

We specify a first emissions game as a stochastic sequential decision
problem.

* Controls

At each decision step, the decision maker has two options: freezing
emissions or increasing emissions:

> SequentialDecisionProblems.CoreTheory.Ctrl _ _ = FreezeOrIncrease

* States

The decision maker can observe three values: the cumulated effects of
its own decisions, of the decisions taken by "others", and a state of
the world. The latter can be either good or bad

> SequentialDecisionProblems.CoreTheory.State t = (Nat, Nat, GoodOrBad)

The idea is that the world starts in a good state but, if the sum of the
cumulated emissions of the decision maker and of the "others" increase
beyond a certain threshold, there is a non-zero probability to turn to a
bad state. Once there, there is no chance to come back to a good state.

In this game, we assume that the decision maker and the "others" take
the same decisions in a competitive setup, see section on rewards.

* Transition function

> threshold : Nat
> threshold = Z

> p   :  Double
> p   =  1.0

> p1  :  NonNegDouble
> p1  =  cast (p   / (p + 1.0))
> p2  :  NonNegDouble
> p2  =  cast (1.0 / (p + 1.0))

> SequentialDecisionProblems.CoreTheory.nexts t (s1, s2, Good) Freeze =
>   if (s1 + s2 <= threshold)
>   then mkSimpleProb [((s1, s2, Good), one)]
>   else mkSimpleProb [((s1, s2, Good), p1), ((s1, s2, Bad), p2)]

> SequentialDecisionProblems.CoreTheory.nexts t (s1, s2, Good) Increase =
>   if (s1 + s2 <= threshold)
>   then mkSimpleProb [((S s1, S s2, Good), one)]
>   else mkSimpleProb [((S s1, S s2, Good), p1), ((S s1, S s2, Bad), p2)]

> SequentialDecisionProblems.CoreTheory.nexts t (s1, s2, Bad) Freeze =
>   mkSimpleProb [((s1, s2, Bad), one)]

> SequentialDecisionProblems.CoreTheory.nexts t (s1, s2, Bad) Increase =
>   mkSimpleProb [((S s1, S s2, Bad), one)]

* |Val| and |LTE|:

> SequentialDecisionProblems.CoreTheory.Val =
>   NonNegDouble.NonNegDouble

> SequentialDecisionProblems.CoreTheory.plus =
>   NonNegDouble.Operations.plus

> SequentialDecisionProblems.CoreTheory.zero =
>   fromInteger @{NumNonNegDouble} 0

> SequentialDecisionProblems.CoreTheory.LTE =
>   NonNegDouble.Predicates.LTE

> SequentialDecisionProblems.FullTheory.reflexiveLTE =
>   NonNegDouble.LTEProperties.reflexiveLTE

> SequentialDecisionProblems.FullTheory.transitiveLTE =
>   NonNegDouble.LTEProperties.transitiveLTE

> SequentialDecisionProblems.FullTheory.monotonePlusLTE =
>   NonNegDouble.LTEProperties.monotonePlusLTE

> SequentialDecisionProblems.CoreTheoryOptDefaults.totalPreorderLTE =
>   NonNegDouble.LTEProperties.totalPreorderLTE

* Reward function

The idea is that, at every step, being in a good world yields more
benefits than being in a bad world:

> benefitsGood : NonNegDouble
> benefitsGood = one

> benefitsBad  : NonNegDouble
> benefitsBad  = NonNegDouble.Constants.zero

Freezing emissions also brings less benefits than increasing
emissions. However, increasing emissions in a bad world yields less
benefits than increasing emissions in a good world:

> benefitsFreeze : NonNegDouble
> benefitsFreeze = NonNegDouble.Constants.zero

> benefitsIncreaseGood : NonNegDouble
> benefitsIncreaseGood = one

> benefitsIncreaseBad : NonNegDouble
> benefitsIncreaseBad = cast 0.9

> using implementation NumNonNegDouble
>
>   SequentialDecisionProblems.CoreTheory.reward _ (_, _, _) Freeze   (_, _, Good) = benefitsGood + benefitsFreeze
>   SequentialDecisionProblems.CoreTheory.reward _ (_, _, _) Increase (_, _, Good) = benefitsGood + benefitsIncreaseGood
>   SequentialDecisionProblems.CoreTheory.reward _ (_, _, _) Freeze   (_, _,  Bad) = benefitsBad  + benefitsFreeze
>   SequentialDecisionProblems.CoreTheory.reward _ (_, _, _) Increase (_, _,  Bad) = benefitsBad  + benefitsIncreaseBad

* Completing the problem specification

To be able to apply the verified, generic backwards induction algorithm
of |CoreTheory| to compute optimal policies for our problem, we have to
explain how the decision maker accounts for uncertainties on rewards
induced by uncertainties in the transition function. We first assume
that the decision maker measures uncertain rewards by their expected
value:

> SequentialDecisionProblems.CoreTheory.meas = expectedValue
> SequentialDecisionProblems.FullTheory.measMon = monotoneExpectedValue

Further on, we have to implement the notions of viability and
reachability. We start by positing that all states are viable for any
number of steps:

> -- Viable : (n : Nat) -> State t -> Type
> SequentialDecisionProblems.CoreTheory.Viable n x = Unit

From this definition, it trivially follows that all elements of an
arbitrary list of states are viable for an arbitrary number of steps:

> viableLemma : {t, n : Nat} -> (xs : List (State t)) -> All (Viable n) xs
> viableLemma  Nil      = Nil
> viableLemma {t} {n} (x :: xs) = () :: (viableLemma {t} {n} xs)

This fact and the (less trivial) result that simple probability
distributions are never empty, see |nonEmptyLemma| in
|MonadicProperties| in |SimpleProb|, allows us to show that the above
definition of |Viable| fulfills |viableSpec1|:

> -- viableSpec1 : (x : State t) -> Viable (S n) x -> GoodCtrl t x
> SequentialDecisionProblems.CoreTheory.viableSpec1 {t} {n} s v =
>   MkSigma Freeze (ne, av) where
>     ne : SequentialDecisionProblems.CoreTheory.NotEmpty (nexts t s Freeze)
>     ne = nonEmptyLemma (nexts t s Freeze)
>     av : SequentialDecisionProblems.CoreTheory.All (Viable {t = S t} n) (nexts t s Freeze)
>     av = viableLemma {t = S t} (support (nexts t s Freeze))

> SequentialDecisionProblems.Utils.finiteViable n x = finiteUnit

> SequentialDecisionProblems.Utils.decidableViable n x = decidableUnit

For reachability, we proceed in a similar way. We say that all states
are reachable

> -- Reachable : State t' -> Type
> SequentialDecisionProblems.CoreTheory.Reachable x' = Unit

which immediately implies |reachableSpec1|:

> -- reachableSpec1 : (x : State t) -> Reachable {t' = t} x -> (y : Ctrl t x) -> All (Reachable {t' = S t}) (nexts t x y)
> SequentialDecisionProblems.CoreTheory.reachableSpec1 {t} x r y = all (nexts t x y) where
>   all : (sp : SimpleProb  (State (S t))) -> SequentialDecisionProblems.CoreTheory.All (Reachable {t' = S t}) sp
>   all sp = all' (support sp) where
>     all' : (xs : List (State (S t))) -> Data.List.Quantifiers.All (Reachable {t' = S t}) xs
>     all' Nil = Nil
>     all' (x :: xs) = () :: (all' xs)

Finally, we have to show that controls are finite

> -- finiteCtrl : {t : Nat} -> (x : State t) -> Finite (Ctrl t x)
> SequentialDecisionProblems.Utils.finiteCtrl _ = finiteFreezeOrIncrease

* Optimal policies, optimal decisions, ...

We can now apply the results of our |CoreTheory| and of the |FullTheory|
to compute verified optimal policies, possible state-control sequences,
etc. To this end, we need to be able to show the outcome of the decision
process. This means implemeting functions to print states and controls:

> -- showState : {t : Nat} -> State t -> String
> SequentialDecisionProblems.Utils.showState {t} (s1, s2, Good) =
>   "(" ++ show s1 ++ "," ++ show s2 ++ ",Good)"
> SequentialDecisionProblems.Utils.showState {t} (s1, s2, Bad) =
>   "(" ++ show s1 ++ "," ++ show s2 ++ ",Bad)"

> -- showControl : {t : Nat} -> {x : State t} -> Ctrl t x -> String
> SequentialDecisionProblems.Utils.showCtrl {t} {x} Freeze = "Freeze"
> SequentialDecisionProblems.Utils.showCtrl {t} {x} Increase = "Increase"

> computation : { [STDIO] } Eff ()
> computation =
>   do putStr ("enter number of steps:\n")
>      nSteps <- getNat
>      case (decidableViable {t = Z} nSteps (Z, Z, Good)) of
>        (Yes v) => do putStrLn ("computing optimal policies ...")
>                      ps   <- pure (backwardsInduction Z nSteps)
>                      putStrLn ("computing optimal controls ...")
>                      mxys <- pure (possibleStateCtrlSeqs (Z, Z, Good) () v ps)
>                      putStrLn "possible state-control sequences:"
>                      putStr "  "
>                      putStrLn (show mxys)
>                      -- mvs <- pure (possibleRewards' mxys)
>                      -- putStrLn "possible rewards:"
>                      -- putStr "  "
>                      -- putStrLn (show mvs)
>                      -- mxyvs <- pure (possibleStateCtrlSeqsRewards' mxys)
>                      -- putStrLn "possible state-control sequences and rewards:"
>                      -- putStr "  "
>                      -- putStrLn (show mxyvs)
>                      -- putStrLn "measure of possible rewards: "
>                      -- putStr "  "
>                      -- putStrLn (show (meas mvs))
>                      -- argmaxmax <- pure (argmaxMax {A = StateCtrlSeq Z nSteps} {B = Val} totalPreorderLTE (support mxyvs) (nonEmptyLemma mxyvs))
>                      -- putStrLn "best possible state-control sequence: "
>                      -- putStr "  "
>                      -- putStrLn (show (fst argmaxmax))
>                      -- putStrLn "best possible reward: "
>                      -- putStr "  "
>                      -- putStrLn (show (snd argmaxmax))
>                      -- -- argminmin <- pure (argminMin totalPreorderLTE (support mxyvs) (nonEmptyLemma mxyvs))
>                      -- -- putStrLn "worst possible state-control sequence: "
>                      -- -- putStr "  "
>                      -- -- putStrLn (show (fst argminmin))
>                      -- -- putStrLn "worst possible reward: "
>                      -- -- putStr "  "
>                      -- -- putStrLn (show (snd argminmin))
>                      putStrLn ("done!")
>        (No _)  => putStrLn ("initial state non viable for " ++ cast {from = Int} (cast nSteps) ++ " steps")

> main : IO ()
> main = run computation

> {-

> ---}

[1] Stanford Encyclopedia of Phylosophy, Causal Decision Theory, 2010

-- Local Variables:
-- idris-packages: ("effects")
-- End:


{- Copied straight from the book -}
module Part2.Sec6_2_2_printf

{- This one is like recursive enumeration -}
data Format = Number Format
             | Str Format
             | Lit String Format
             | End

{-  Nice recursive definition that ends up resolving to a long function returning String.
   This ends up being implementable with TypeFamilies and DataKinds (for Format) in Haskell. -}
PrintfType : Format -> Type
PrintfType (Number fmt) = (i : Int) -> PrintfType fmt
PrintfType (Str fmt) = (str : String) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType End = String

{- CPS implemenation that still maps nicely to Haskell -}
printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str)
printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)
printfFmt End acc = acc

{- No dependent typing here -}
toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
                             Lit lit chars' => Lit (strCons c lit) chars'
                             fmt => Lit (strCons c "") fmt

{- Hah, so simple! Currently no such luck in Haskell -}
printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""


module Subst

-- This module constructs an expressively typed substitution
-- function 'subst' for substituting variables in the simply-typed
-- lambda calculus.
--
-- The key point is that the expressive type signature of the
-- function 'subst' can be read as the following theorem:
--
--    "Given a variable with de Bruijn index 'idx'.
--     Given further the terms
--       ts : Term sctx s, and
--       tt : Term ctx  t.
--     Then 'subst ts idx tt' has type 't' in context '(remove idx ctx)++sctx'."
--
-- Note that 'subst ts idx tt' is typically written as "tt[ts/(TVar idx)]".
--
-- Note that the theorem that is expressed by the type signature
-- of 'subst' is usually referred to as
--
--    *** the substitution lemma ***
--
-- and casually summarized as
--
--    *** substitution preserves type ***.
--

import Term

%default total

------------------------------------------------------------
-- Begin: SHIFTING, I.E. ADDING UNUSED VARIABLES TO CONTEXTS

-- When adding variables in 'ctx' in the middle of
-- a context 'ctx1++ctx2', de Bruijn indices must
-- be adjusted accordingly:
shift : (ctx : Context) -> HasType (ctx1++ctx2) t ->
        HasType (ctx1++(ctx++ctx2)) t
shift {ctx1 = []}         []       x        = x
shift {ctx1 = []}         (_::ctx) x        = Next $ shift {ctx1=[]} ctx x
shift {ctx1 = (_::ctx1')} ctx      First    = First
shift {ctx1 = (_::ctx1')} ctx      (Next x) = Next $ shift {ctx1=ctx1'} ctx x

shift' : (ctx : Context) -> HasType (ctx1++ctx2) t ->
         HasType ((ctx1++ctx)++ctx2) t
shift' {ctx1} {ctx2} ctx ht = let assoc = appendAssociative ctx1 ctx ctx2
                                  sh    = shift {ctx1=ctx1} {ctx2=ctx2} ctx ht
                              in rewrite (sym assoc) in sh

-- Adjust terms for the (unused) variables in 'ctx':
shiftTerm : (ctx : Context) -> Term (ctx1++ctx2) t ->
            Term (ctx1++(ctx++ctx2)) t
--
shiftTerm ctx (TVar ht) = let sht = shift ctx ht
                          in TVar sht
--
shiftTerm {ctx1} {ctx2} {t = t1:->:t2} ctx (TAbs e) =
  let e' = shiftTerm {ctx1=(t1::ctx1)} {ctx2=ctx2} ctx e
  in TAbs e'
--
shiftTerm {ctx1} {ctx2} ctx (TApp e1 e2) =
  let e1' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e1
      e2' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e2
  in TApp e1' e2'
--
shiftTerm {ctx1} {ctx2} ctx (TFix e) =
  let e' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e
  in TFix e'
--
shiftTerm ctx TZero = TZero
--
shiftTerm {ctx1} {ctx2} ctx (TSucc e) =
  let e' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e
  in TSucc e'
--
shiftTerm {ctx1} {ctx2} ctx (TPred e) =
  let e' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e
  in TPred e'
--
shiftTerm {ctx1} {ctx2} ctx (TIfz e1 e2 e3) =
  let e1' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e1
      e2' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e2
      e3' = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx e3
  in TIfz e1' e2' e3'

shiftTerm' : (ctx : Context) -> Term (ctx1++ctx2) t -> Term ((ctx1++ctx)++ctx2) t
shiftTerm' {ctx1} {ctx2} ctx ht = let assoc = appendAssociative ctx1 ctx ctx2
                                      sh    = shiftTerm {ctx1=ctx1} {ctx2=ctx2} ctx ht
                                  in rewrite (sym assoc) in sh

-- Shifting a de Bruijn index 'x' with the empty
-- context '[]' preserves the de Bruijn index 'x':
shiftNil : {ctx1 : Context} -> {ctx2 : Context} ->
           {t : Ty} -> {x : HasType (ctx1++ctx2) t} ->
           shift [] x = x
shiftNil {ctx1 = []}      {ctx2 = ctx2} {x = x}        = Refl
shiftNil {ctx1 = _::ctx'} {ctx2 = ctx2} {x = First}    = Refl
shiftNil {ctx1 = _::ctx'} {ctx2 = ctx2} {x = (Next x)} =
  let eq = shiftNil {ctx1=ctx'} {ctx2=ctx2} {x=x}
  in cong {f = \z => Next z} eq

-- Shifting a term 'e' with the empty
-- context '[]' preserves the term 'e':
shiftTermNil : {ctx1 : Context} -> {ctx2 : Context} ->
               {t : Ty} -> {e : Term (ctx1++ctx2) t} ->
               shiftTerm [] e = e
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {t=t} {e = (TVar ht)} =
  cong {f = \z => TVar z} $ shiftNil {ctx1=ctx1} {ctx2=ctx2} {t=t} {x=ht}
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {t=t1:->:t2} {e = (TAbs e')} =
  let eq = shiftTermNil {ctx1=(t1::ctx1)} {ctx2=ctx2} {t=t2} {e=e'}
  in cong {f = \z => TAbs z} eq
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {e = (TApp e1 e2)} =
  let eq1 = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e1}
      eq2 = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e2}
      c   = cong {f = \z => TApp z e2} eq1
      c'  = cong {f = \z => TApp (shiftTerm [] e1) z} eq2
  in trans c' c
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {e = (TFix e')} =
  let eq = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e'}
  in cong {f = \z => TFix z} eq
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {e = TZero} = Refl
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {e = (TSucc e')} =
  let eq = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e'}
  in cong {f = \z => TSucc z} eq
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {e = (TPred e')} =
  let eq = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e'}
  in cong {f = \z => TPred z} eq
--
shiftTermNil {ctx1 = ctx1} {ctx2 = ctx2} {e = (TIfz e1 e2 e3)} =
  let eq1 = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e1}
      eq2 = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e2}
      eq3 = shiftTermNil {ctx1=ctx1} {ctx2=ctx2} {e=e3}
      c   = cong {f = \z => TIfz z e2 e3} eq1
      c'  = cong {f = \z => TIfz (shiftTerm [] e1) z e3} eq2
      c'' = cong {f = \z => TIfz (shiftTerm [] e1) (shiftTerm [] e2) z} eq3
  in trans (trans c'' c') c

-- End: SHIFTING, I.E. ADDING UNUSED VARIABLES TO CONTEXTS
----------------------------------------------------------

-----------------------------------------------------------------------------
-- Begin: SUBSTITUTION PRESERVES TYPING OF EXPRESSIONS IN THE LAMBDA CALCULUS

subst_var : Term sctx s ->            -- Term of type 's' is subtituted in.
            (idx : HasType ctx s) ->  -- Index of the variable in 'ctx' that is subsituted for.
                                      -- (and hence must have type 's').
            HasType ctx t ->          -- Substitution takes place inside the variable
                                      -- with this index.
            Term ((remove ctx idx)++sctx) t
--
subst_var {sctx} {s=s} {ctx=s::ctx'} {t=s} ts First First =
  shiftTerm' {ctx1=[]} {ctx2=sctx} ctx' ts
--
subst_var {sctx} {s=s} {ctx=s::ctx'} {t=t} ts First (Next htv) =
  let anr1 = sym $ appendNilRightNeutral ctx'
      htv1 = replace {P = \z => HasType z t} anr1 htv
      htv2 = shift {ctx1=ctx'} {ctx2=[]} sctx htv1
      anr2 = appendNilRightNeutral sctx
      htv3 = replace {P = \z => HasType (ctx'++z) t} anr2 htv2
   in TVar htv3
--
subst_var {sctx} {s=s} {ctx=u::ctx'} {t=u} ts (Next _) First = TVar First
--
subst_var {sctx} {s=s} {ctx=u::ctx'} {t=t} ts (Next x) (Next y) =
  let t' = subst_var ts x y
  in shiftTerm {ctx1=[]} {ctx2=(remove ctx' x)++sctx} [u] t'

export subst : Term sctx s ->            -- Term of type 's' is substituted in.
               (idx : HasType ctx s) ->  -- Index of the variable in 'ctx' that is substituted for
                                         -- (and hence must have type 's').
               Term ctx t  ->            -- Substitution takes place inside this
                                         -- term of type 't'
               Term ((remove ctx idx)++sctx) t
--
subst ts ht (TVar htv) = subst_var ts ht htv
--
subst {ctx} {t = t1:->:t2} ts ht (TAbs e) =
  TAbs $ subst {ctx=t1::ctx} ts (Next ht) e
--
subst ts ht (TApp e1 e2)    = TApp (subst ts ht e1) (subst ts ht e2)
subst ts ht (TFix e)        = TFix (subst ts ht e)
subst ts ht TZero           = TZero
subst ts ht (TSucc e)       = TSucc (subst ts ht e)
subst ts ht (TPred e)       = TPred (subst ts ht e)
subst ts ht (TIfz e1 e2 e3) = TIfz (subst ts ht e1)
                                   (subst ts ht e2)
                                   (subst ts ht e3)

-- Substituting a term 'e' into a single variable 'TVar First'
-- gives back the same term 'e' but in a shifted context:
substInVar' : (e : Term sctx t) ->
             subst {ctx=(t::ctx')} {s=t} {t=t} e First (TVar First) = shiftTerm {ctx1=[]} {ctx2=sctx} ctx' e
substInVar' e = Refl

-- Specialization of the previous result to a minimal
-- context '[t]' gives back exactly term 'e':
substInVar : (e : Term sctx t) ->
             subst {ctx=[t]} {s=t} {t=t} e First (TVar First) = e
substInVar {sctx} e = shiftTermNil {ctx1=[]} {ctx2=sctx} {e=e}

-- End: SUBSTITUTION PRESERVES TYPING OF EXPRESSIONS IN THE LAMBDA CALCULUS
---------------------------------------------------------------------------

--------------------------------
-- Begin: DIVERGING TERM 'omega'

-- Define 'omega' to be the diverging term that
-- is the fix-point of the identity function:
public export omega : Term [] TyNat
omega = TFix (TAbs $ TVar First)

-- To show (later) that 'omega' diverges, one needs the result that
-- substituting 'omega' into a single variable 'TVar FZ' reproduces
-- the term 'omega' itself:
export substOmega : subst {ctx=[TyNat]} {s=TyNat} {t=TyNat} Subst.omega First (TVar First) = Subst.omega
-- Note that while 'substOmega' is a special case of the more general
-- result 'substInVar' (see above), the general result is in fact not
-- needed. This is because the Idris type checker can evaluate
-- 'shiftTerm _ omega' (resulting from 'subst'), but it cannot
-- evaluate 'shiftTerm _ e' for a variable 'e' because 'shiftTerm'
-- is defined by recursion on the structure of 'e'.
substOmega = Refl

-- End: DIVERGING TERM 'omega'
------------------------------


module Addition.Absorb

import Data.Vect
import Common.Util
import Common.Interfaces
import Specifications.DiscreteOrderedGroup
import Specifications.OrderedRing
import Proofs.GroupTheory
import Addition.Carry
import Addition.Scaling
import Addition.AbsorptionLemmas
import Addition.Adhoc

%default total
%access export

||| This is a proof friendly semantics function.  Consider a tail
||| recursive variation for run time use.
public export
phi : Ringops s => (radix : s) -> (lsdf : Vect n s) -> (msc : Carry) -> s
phi radix (x :: xs) c = x + radix * phi radix xs c
phi radix [] c = value c

||| The result of absorbing carry digits:
|||
|||           in1    in2    in3
|||           ou1    ou2    pen + unk
|||    msc    abs    abs    unk
|||
||| unk = the least significant carry is still unknown
||| pen = ouput of reduction before absorbing the unknown carry
||| msc = most significant carry
||| abs = carry already absorbed in the corresponding output
data Absorption :
  (k : Nat) ->
  (constraints : s -> Vect k s -> Type) ->
  (semantics : Vect (S k) s -> Carry -> s) ->
  (inputs : Vect (S k) s) -> Type
  where MkAbsorption :
    (msc : Carry) ->
    (pending : s) ->
    (outputs : Vect k s) ->
    (constraints pending outputs) ->
    (semantics inputs O = semantics (pending :: outputs) msc) ->
    Absorption k constraints semantics inputs

outputs : Absorption {s} k _ _ _ -> (Carry, Vect (S k) s)
outputs (MkAbsorption c p o _ _) = (c, reverse (p :: o))

absorptionBase : Ringops s =>
  DiscreteOrderedRingSpec {s} (+) Zero Ng (*) leq One ->
  (radix : s) ->
  (red : Reduction (+) Zero Ng leq One u radix) ->
  Absorption Z (Ranges leq Ng u (u + Ng One)) (phi radix) [input red]
absorptionBase spec radix (MkReduction i c o invariant outRange) =
  MkAbsorption c o [] (MkRanges outRange []) o3
  where
    o1 : o + radix * value c = i
    o1 = rewriteInvariant (unitalRing spec) radix i o c invariant
    o2 : i = i + radix * value O
    o2 = adhocIdentity2 (ring (unitalRing spec)) i radix
    o3 : phi radix [i] O = phi radix [o] c
    o3 = sym (o1 === o2)

arithLemma : Ringops s => UnitalRingSpec {s} (+) Zero Ng (*) One ->
  (msc : Carry) ->
  (pending : s) ->
  (outputs : Vect k s) ->
  (inputs : Vect (S k) s) ->
  (red : Reduction {s} (+) Zero Ng _ One u radix) ->
  (ih : phi radix inputs O = phi radix (pending :: outputs) msc) ->
  phi radix (input red :: inputs) O =
  phi radix (output red :: (value (carry red) + pending) :: outputs) msc
arithLemma {s} {radix} spec msc pending outputs inputs
        (MkReduction i c o invariant _) inductionHypothesis =
  let
    adhoc = adhocIdentity1 (ring spec) pending o radix (value c) o2
    shift = radix * phi radix inputs O
    shifted = cong {f = (+ shift)} o1
  in shifted @== adhoc
  where
    o1 : o + radix * value c = i
    o1 = rewriteInvariant spec radix i o c invariant
    o2 : phi radix inputs O = pending + radix * phi radix outputs msc
    o2 = inductionHypothesis

absorptionStep : Ringops s =>
  DiscreteOrderedRingSpec {s} (+) Zero Ng (*) leq One ->
  (radix : s) ->
  (red : Reduction (+) Zero Ng leq One u radix) ->
  Absorption k (Ranges leq Ng u (u + Ng One)) (phi radix) inputs ->
  Absorption (S k) (Ranges leq Ng u (u + Ng One))
    (phi radix) (input red :: inputs)
absorptionStep spec radix red@(MkReduction _ _ _ _ reducedRange)
       (MkAbsorption {inputs} msc pending outputs ranges invariant) =
  let absorb = value (carry red) + pending
  in MkAbsorption msc (output red) (absorb :: outputs)
      (rangeLemma (discreteOrderedGroup spec) ranges reducedRange (carry red))
      (arithLemma (unitalRing spec) msc pending outputs inputs red invariant)


module Libraries.Data.Fin

import public Data.Fin

%default total

-- TODO: Remove this, once Data.Fin.strengthen from base is available
--       to the compiler

export
strengthen : {n : _} -> Fin (S n) -> Maybe (Fin n)
strengthen {n = S _} FZ = Just FZ
strengthen {n = S _} (FS p) with (Libraries.Data.Fin.strengthen p)
  strengthen (FS _) | Nothing = Nothing
  strengthen (FS _) | Just q  = Just $ FS q
strengthen _ = Nothing


module Test.Int

import Data.Prim.Int
import Data.SOP
import Hedgehog
import Test.RingLaws

allInt : Gen Int
allInt = int (linear (-0x8000000000000000) 0xffffffffffffffff)

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

export
props : Group
props = MkGroup "Int16" $
  [ ("prop_comp",   prop_comp)
  ] ++ ringProps allInt


module Leibniz
import Control.Monad.Identity

data Eq : (a : Type) -> (b : Type) -> Type where
  Subs : ({f : Type -> Type} -> f a -> f b) -> Eq a b

refl : Eq a a
refl = Subs id

subst : {f : Type -> Type} -> Eq a b -> f a -> f b
subst (Subs subs) fa = subs fa

trans : Eq a b -> Eq b c -> Eq a c
trans ab bc = subst bc ab

cast : Eq a b -> a -> b
cast eq = runIdentity . subst eq . Id

Flip : (Type -> Type -> Type) -> Type -> Type -> Type
Flip f a b = f b a

symm : Eq a b -> Eq b a
symm eq = subst {f = Flip Eq a} eq refl


> module Nat.GCDEuclid

> import Nat.GCD
> import Nat.Divisor
> import Nat.DivisorProperties
> import Nat.Operations
> import Nat.LTEProperties
> import Nat.OperationsProperties
> import Sigma.Sigma
> import Pairs.Operations

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

Euclid's greatest common divisor algorithm

> euclidGCD1 : GCD m m Z
> euclidGCD1 {m} = MkGCD (anyDivisorAny m) (anyDivisorZ m) (\ d' => \ d'Dm => \ d'DZ => d'Dm)

> euclidGCD2 : GCD m Z m
> euclidGCD2 {m} = MkGCD (anyDivisorZ m) (anyDivisorAny m) (\ d' => \ d'DZ => \ d'Dm => d'Dm)

> euclidGCD3 : m `LTE` n -> GCD d m (n - m) -> GCD d m n
> euclidGCD3 {m} {n} {d} p (MkGCD dDm dDnmm q) = MkGCD dDm dDn q' where
>   dDnmmpm : d `Divisor` ((n - m) + m)
>   dDnmmpm = divisorPlusLemma2 m (n - m) d dDm dDnmm
>   dDn : d `Divisor` n
>   dDn = replace {x = (n - m) + m}
>                 {y = n}
>                 {P = \ ZUZU => d `Divisor` ZUZU}
>                 (plusRightInverseMinus m n p)
>                 dDnmmpm
>   q' : (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d
>   q' d' d'Dm d'Dn = q d' d'Dm d'Dnmm where
>     d'Dnmm : d' `Divisor` (n - m)
>     d'Dnmm = divisorMinusLemma m n d' d'Dm d'Dn

> euclidGCD4 : Not (m `LTE` n) -> GCD d (m - n) n -> GCD d m n
> euclidGCD4 {m} {n} {d} p (MkGCD dDmmn dDn q) = MkGCD dDm dDn q' where
>   dDmmnpn : d `Divisor` ((m - n) + n)
>   dDmmnpn = divisorPlusLemma1 (m - n) n d dDmmn dDn
>   dDm : d `Divisor` m
>   dDm = replace {x = (m - n) + n}
>                 {y = m}
>                 {P = \ ZUZU => d `Divisor` ZUZU}
>                 (plusRightInverseMinus n m (notLTELemma1 m n p))
>                 dDmmnpn
>   q' : (d' : Nat) -> d' `Divisor` m -> d' `Divisor` n -> d' `Divisor` d
>   q' d' d'Dm d'Dn = q d' d'Dmmn d'Dn where
>     d'Dmmn : d' `Divisor` (m - n)
>     d'Dmmn = divisorMinusLemma n m d' d'Dn d'Dm

> euclidGCD : (m : Nat) -> (n : Nat) -> Sigma Nat (\ d => GCD d m n)
> euclidGCD    m   Z    = assert_total (MkSigma m euclidGCD1)
> euclidGCD  Z       n  = assert_total (MkSigma n euclidGCD2)
> euclidGCD (S m) (S n) with (decLTE (S m) (S n))
>   | (Yes p) = assert_total (MkSigma gcd (euclidGCD3 p P)) where
>     gcdP : Sigma Nat (\ d => GCD d (S m) (S n - S m))
>     gcdP = euclidGCD (S m) (S n - S m)
>     gcd  : Nat
>     gcd  = getWitness gcdP
>     P    : GCD gcd (S m) (S n - S m)
>     P    = getProof gcdP
>   | (No  p) = assert_total (MkSigma gcd (euclidGCD4 p P)) where
>     gcdP : Sigma Nat (\ d => GCD d (S m - S n) (S n))
>     gcdP = euclidGCD (S m - S n) (S n)
>     gcd  : Nat
>     gcd  = getWitness gcdP
>     P    : GCD gcd (S m - S n) (S n)
>     P    = getProof gcdP


module Main

import Data.Vect

data DataStore: Type where
    MkData: (size: Nat) -> (items: Vect size String) -> DataStore

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

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

addToStore: DataStore -> String -> DataStore
addToStore (MkData size items) newItem = MkData _ (addToData items)
    where
        addToData: Vect old String -> Vect (S old) String
        addToData [] = [newItem]
        addToData (x :: xs) = x :: addToData xs

data Command = Add String
						 | Get Integer
						 | Size
             | Quit

parseCommand : (cmd : String) -> (args : String) -> Maybe Command
parseCommand "add" str = Just (Add str)
parseCommand "get" val = case all isDigit (unpack val) of
	True  => Just(Get(cast val))
	False => Nothing
parseCommand "size" "" = Just Size
parseCommand "quit" "" = Just Quit
parseCommand _ _ = Nothing

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

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

total processCommand : (cmd : Command) -> (store : DataStore) -> Maybe (String, DataStore)
processCommand (Add item) store =
	let
		newStore = addToStore store item
		newId = show (size store)
	in
		Just("ID: " ++ newId ++ "\n", newStore)
processCommand (Get pos) store = getEntry pos store
processCommand Size store = Just("Size: " ++ show (size store) ++ "\n", store)
processCommand Quit store = Nothing

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input = case parse input of
    Nothing => Just("Invalid command\n", store)
    Just cmd => processCommand cmd store

main : IO ()
main = replWith (MkData _ []) ":>> " processInput


module Data.Iso

public export
record Iso (a, b : Type) where
  constructor MkIso
  to : a -> b
  from : b -> a
  toFrom : (x : b) -> to (from x) === x
  fromTo : (x : a) -> from (to x) === x

-- TODO: transitive and reflexive for ISO


data BNat = BZ | O BNat | E BNat

data BLT : BNat -> BNat -> Type where
  BLT_ZO : BLT BZ (O bn)
  BLT_ZE : BLT BZ (E bn)
  BLT_OO : BLT bn bm -> BLT (O bn) (O bm)
  BLT_OE : BLT bn bm -> BLT (O bn) (E bm)
  BLT_OE_Eq : BLT (O bn) (E bn)
  BLT_EO : BLT bn bm -> BLT (E bn) (O bm)
  BLT_EE : BLT bn bm -> BLT (E bn) (E bm)

notLtz : BLT bn BZ -> Void
notLtz x = ?notLtz_rhs


module Utils.ComplexAddon

import Data.Complex

%default total
%access public export

implementation (Fractional a, Neg a) => Fractional (Complex a) where
    (/) (a:+b) (c:+d) = let
                          real = (a*c+b*d)/(c*c+d*d)
                          imag = (b*c-a*d)/(c*c+d*d)
                        in
                          (real:+imag)

implementation (Cast a b) => Cast (Complex a) (Complex b) where
  cast (x :+ y) = (cast x :+ cast y)


Ty : Type
Ty = (Ty    : Type)
   ->(empty : Ty)
   ->(arr   : Ty -> Ty -> Ty)
   -> Ty

empty : Ty
empty = \ _, empty, _ => empty

arr : Ty -> Ty -> Ty
arr = \ a, b, ty, empty, arr => arr (a ty empty arr) (b ty empty arr)

Con : Type
Con = (Con : Type)
 ->(nil  : Con)
 ->(snoc : Con -> Ty -> Con)
 -> Con

nil : Con
nil = \ con, nil, snoc => nil

snoc : Con -> Ty -> Con
snoc = \ g, a, con, nil, snoc => snoc (g con nil snoc) a

Var : Con -> Ty -> Type
Var = \ g, a =>
    (Var : Con -> Ty -> Type)
 -> (vz  : (g : _)-> (a : _) -> Var (snoc g a) a)
 -> (vs  : (g : _)-> (b : _) ->  (a : _) -> Var g a -> Var (snoc g b) a)
 -> Var g a

vz : {g : _}-> {a : _} -> Var (snoc g a) a
vz = \ var, vz, vs => vz _ _

vs : {g : _} -> {B : _} -> {a : _} -> Var g a -> Var (snoc g B) a
vs = \ x, var, vz, vs => vs _ _ _ (x var vz vs)

Tm : Con -> Ty -> Type
Tm = \ g, a =>
    (Tm    : Con -> Ty -> Type)
 -> (var   : (g : _) -> (a : _) -> Var g a -> Tm g a)
 -> (lam   : (g : _) -> (a : _) -> (B : _) -> Tm (snoc g a) B -> Tm g (arr a B))
 -> (app   : (g : _) -> (a : _) -> (B : _) -> Tm g (arr a B) -> Tm g a -> Tm g B)
 -> Tm g a

var : {g : _} -> {a : _} -> Var g a -> Tm g a
var = \ x, tm, var, lam, app => var _ _ x

lam : {g : _} -> {a : _} -> {B : _} -> Tm (snoc g a) B -> Tm g (arr a B)
lam = \ t, tm, var, lam, app => lam _ _ _ (t tm var lam app)

app : {g:_}->{a:_}->{B:_} -> Tm g (arr a B) -> Tm g a -> Tm g B
app = \ t, u, tm, var, lam, app => app _ _ _ (t tm var lam app) (u tm var lam app)

v0 : {g:_}->{a:_} -> Tm (snoc g a) a
v0 = var vz

v1 : {g:_}->{a:_}-> {B:_}-> Tm (snoc (snoc g a) B) a
v1 = var (vs vz)

v2 : {g:_}-> {a:_}-> {B:_}-> {C:_} -> Tm (snoc (snoc (snoc g a) B) C) a
v2 = var (vs (vs vz))

v3 : {g:_}-> {a:_}-> {B:_}-> {C:_}-> {D:_} -> Tm (snoc (snoc (snoc (snoc g a) B) C) D) a
v3 = var (vs (vs (vs vz)))

v4 : {g:_}-> {a:_}-> {B:_}-> {C:_}-> {D:_}-> {E:_}-> Tm (snoc (snoc (snoc (snoc (snoc g a) B) C) D) E) a
v4 = var (vs (vs (vs (vs vz))))

test : {g:_}-> {a:_} -> Tm g (arr (arr a a) (arr a a))
test  = lam (lam (app v1 (app v1 (app v1 (app v1 (app v1 (app v1 v0)))))))


data Vect: Nat -> Type -> Type where
  Nil : Vect Z a
  Cons : a -> Vect x a -> Vect (S x) a

insert : a -> Vect x a -> Vect (S x) a
insert = Cons


-- HOF.idr
-- Higher order functions

twice : (a -> a) -> a -> a
twice f x = f (f x)

Shape : Type
rotate : Shape -> Shape

-- taken from Generic.idr:
double : Num ty => ty -> ty
double x = x + x

quadruple : Num a => a -> a
quadruple = twice double

turn_around : Shape -> Shape
turn_around = twice rotate


data PowerSource = Petrol | Pedal | Electric

-- 4.2.4 Exercises
-- Extend the Vehicle data type so that it supports unicycles and motorcycles, and wheels and refuel
data Vehicle : PowerSource -> Type where
     Bicycle : Vehicle Pedal
     Unicycle : Vehicle Pedal
     Car : (fuel : Nat) -> Vehicle Petrol
     Bus : (fuel : Nat) -> Vehicle Petrol
     Motorcycle : (fuel : Nat) -> Vehicle Petrol
     Tram : (charge : Nat) -> Vehicle Electric
     ElectricCar : (charge : Nat) -> Vehicle Electric

wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels Unicycle = 1
wheels (Car fuel) = 4
wheels (Bus fuel) = 4
wheels (Tram charge) = 40
wheels (ElectricCar charge) = 4

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Bus 120

data Vect : Nat -> Type -> Type where
  Nil : Vect Z a
  (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a
%name Vect xs, ys, zs


module RingProperties

import Ring
import Monoid
import Group
import Group_property

%access public export

|||Auxiliary function that provzs that if a+a=a thzn a=0
total
aplusaZ: (r: Type) -> (pfr: Ring r) -> (a: r) -> ((Ring_Add r pfr a a) =a) -> (a = (DPair.fst(RingAdditive_id r pfr)))
aplusaZ r (MkRing r (+) (*) pfr) a prf = (Group_property_4 r (+) (Basics.fst (Basics.fst pfr)) a a z (trans prf (sym (Basics.fst (pfz a))) )) where
  z: r
  z = (DPair.fst(RingAdditive_id r (MkRing r (+) (*) pfr)))
  pfz: (a: r) -> (a+z=a, z+a=a)
  pfz = DPair.snd (RingAdditive_id r (MkRing r (+) (*) pfr))

|||Proof that 0*a = 0
total
Zmultleft: (r: Type) -> (pfr: Ring r) -> (a: r) -> ((Ring_Mult r pfr (DPair.fst(RingAdditive_id r pfr)) a) = (DPair.fst(RingAdditive_id r pfr)))
Zmultleft r (MkRing r (+) (*) pfr) a = (aplusaZ r (MkRing r (+) (*) pfr) (z*a) (
    trans (sym (pfd a z z)) (cong {f= \p => p*a} (pfz z))
  ) ) where
  z: r
  z = (DPair.fst(RingAdditive_id r (MkRing r (+) (*) pfr)))
  pfz: (a: r) -> (a+z=a)
  pfz a = Basics.fst ((DPair.snd (RingAdditive_id r (MkRing r (+) (*) pfr))) a)
  pfd: (a: r) -> (b: r) -> (c: r) -> ((b+c)*a = (b*a) + (c*a))
  pfd a b c = Basics.snd ((Basics.snd (Basics.snd pfr)) a b c)

|||Proof that a*0 = 0
total
Zmultright: (r: Type) -> (pfr: Ring r) -> (a: r) -> ((Ring_Mult r pfr a (DPair.fst(RingAdditive_id r pfr))) = (DPair.fst(RingAdditive_id r pfr)))
Zmultright r (MkRing r (+) (*) pfr) a = (aplusaZ r (MkRing r (+) (*) pfr) (a*z) (
    trans (sym (pfd a z z)) (cong {f= \p => a*p} (pfz z))
    ) ) where
    z: r
    z = (DPair.fst(RingAdditive_id r (MkRing r (+) (*) pfr)))
    pfz: (a: r) -> (a+z=a)
    pfz a = Basics.fst ((DPair.snd (RingAdditive_id r (MkRing r (+) (*) pfr))) a)
    pfd: (a: r) -> (b: r) -> (c: r) -> (a*(b+c) = (a*b) + (a*c))
    pfd a b c = Basics.fst ((Basics.snd (Basics.snd pfr)) a b c)

|||Proof that for a ring homomorphism f between rings with identity, f(0) = 0
total
RHomZtoZ: (r1: Type) -> (pf1: Ring r1) -> (r2: Type) -> (pf2: Ring r2) -> (f: r1 -> r2) -> RHom r1 pf1 r2 pf2 f -> f(fst(RingAdditive_id r1 pf1)) = fst (RingAdditive_id r2 pf2)
RHomZtoZ r1 (MkRing r1 ((+)) (m) pf1) r2 (MkRing r2 (*) m1 pf2) f pfhom = aplusaZ r2 (MkRing r2 (*) m1 pf2) (f z1) (
    trans
    (sym (Basics.fst(pfhom z1 z1)))
    (cong (Basics.fst(pfid1 z1)))
    ) where
  z1: r1
  z1 = fst(RingAdditive_id r1 (MkRing r1 ((+)) (m) pf1))
  pfid1: (a : r1) -> ((a+z1) = a, (z1+a) = a)
  pfid1 = snd(RingAdditive_id r1 (MkRing r1 ((+)) (m) pf1))

|||Proof that for a ring homomorphism f, f(0) = 0
total
IRHomZtoZ: (r1: Type) -> (pf1: Ring_with_identity r1) -> (r2: Type) -> (pf2: Ring_with_identity r2) -> (f: r1 -> r2) -> IRHom r1 pf1 r2 pf2 f -> f(fst(RingAdditive_id r1 (Ring_with_identity_isRing r1 pf1))) = fst (RingAdditive_id r2 (Ring_with_identity_isRing r2 pf2))
IRHomZtoZ r1 (MkRing_with_identity r1 ((((+)))) (m) (a, b)) r2 (MkRing_with_identity r2 (((*))) (m1) (a', b')) f pfhom = aplusaZ r2 prf2 (f z1) (
    trans
    (sym (Basics.fst(pfhom z1 z1)))
    (cong (Basics.fst(pfid1 z1)))
    ) where
  prf1: Ring r1
  prf1 = MkRing r1 (+) (m) (a, ((Basics.fst (Basics.fst b)), (Basics.snd b)))
  prf2: Ring r2
  prf2 = MkRing r2 (*) (m1) (a', ((Basics.fst (Basics.fst b')), (Basics.snd b')))
  z1: r1
  z1 = fst(RingAdditive_id r1 prf1)
  pfid1: (a : r1) -> ((a + z1) = a, (z1 + a) = a)
  pfid1 a = snd(RingAdditive_id r1 prf1) a


module DataStore

import Data.Strings
import Data.Vect
import System.REPL

%default total

data DataStore : Type where
  MkData : (size : Nat) -> (items : Vect size String) -> DataStore

size : DataStore -> Nat
size (MkData size' _) = size'

items : (store : DataStore) -> Vect (size store) String
items (MkData _ items') = items'

addToStore : (store : DataStore) -> String -> DataStore
addToStore (MkData size items) newItem = MkData _ (addToData items)
  where
    addToData : Vect old String -> Vect (S old) String
    addToData [] = [newItem]
    addToData (item :: items) = item :: addToData items

data Command = Add String
             | Get Integer
             | Quit

parseCommand : (cmd : String) -> (args : String) -> Maybe Command
parseCommand "add" str = Just (Add str)
parseCommand "get" val = case all isDigit (unpack val) of
                              False => Nothing
                              True => Just (Get (cast val))
parseCommand "quit" "" = Just Quit
parseCommand _ _ = Nothing

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

getEntry : (store : DataStore) -> (pos : Integer) -> Maybe (String, DataStore)
getEntry store pos = case integerToFin pos (size store) of
                          Nothing => Just ("Invalid index: " ++ show pos ++ "\n", store)
                          Just idx => Just (show (index idx (items store)) ++ "\n", store)

processCommand : (store : DataStore) -> (cmd : Command) -> Maybe (String, DataStore)
processCommand store (Add item) = Just ("ID" ++ show (size store) ++ "\n", addToStore store item)
processCommand store (Get idx) = getEntry store idx
processCommand store Quit = Nothing

processInput : (store : DataStore) -> String -> Maybe (String, DataStore)
processInput store inp =
  case parse inp of
       Nothing => Just ("Invalid command\n", store)
       Just cmd => processCommand store cmd

partial
main : IO ()
main = replWith (MkData _ []) "Command: " processInput


module Main

import Data.Vect

data DataStore : Type where
    MkData : (size : Nat) ->
             (items : Vect size String) ->
             DataStore

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

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

addToStore : DataStore -> String -> DataStore
addToStore (MkData size items) newitem = MkData _ (addToData items)
    where
        addToData : Vect old String -> Vect (S old) String
        addToData [] = [newitem]
        addToData (x :: xs) = x :: addToData xs

data Command = Add String
             | Get Integer
             | Search String
             | Size
             | Quit

parseCommand : (cmd : String) -> (args : String) -> Maybe Command
parseCommand "add" str = Just (Add str)
parseCommand "get" val = case all isDigit (unpack val) of
                              False => Nothing
                              True => Just (Get (cast val))
parseCommand "search" substr = Just (Search substr)
parseCommand "size" "" = Just Size
parseCommand "quit" "" = Just Quit
parseCommand _ _ = Nothing

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

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

getBySubstr : (substr : String) -> (store : DataStore) -> Maybe (String, DataStore)
getBySubstr substr store@(MkData s is) = Just (printEntries is 0, store)
    where
        printEntries : Vect n String -> Integer -> String
        printEntries [] ind = ""
        printEntries (y :: ys) ind =
            case isInfixOf substr y of
                False => printEntries ys (ind + 1)
                True => show ind ++ " " ++ y ++ "\n" ++ printEntries ys (ind + 1)

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store inp =
    case parse inp of
        Nothing => Just ("Invalid command\n", store)
        Just (Add item) =>
        Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
        Just (Get pos) => getEntry pos store
        Just (Search substr) => getBySubstr substr store
        Just Size => Just ("Store has " ++ show (size store) ++ " entries.\n", store)
        Just Quit => Nothing

main : IO ()
main = replWith (MkData _ []) "Command: " processInput


data Direction = North
               | East
               | South
               | West

turn_clockwise : Direction -> Direction
turn_clockwise North = East
turn_clockwise East = South
turn_clockwise South = West
turn_clockwise West = North

data Shape = ||| A triangle, with base length and height
             Triangle Double Double
           | ||| A rectangle with length and height
             Rectangle Double Double
           | ||| A circle, with its radius
             Circle Double

area : Shape -> Double
area (Triangle base height) = 0.5 * base * height
area (Rectangle length height) = length * height
area (Circle radius) = pi * radius * radius

data Picture = Primitive Shape
             | Combine Picture Picture
             | Rotate Double Picture
             | Translate Double Double Picture

rectangle : Picture
rectangle = Primitive (Rectangle 20 10)

circle : Picture
circle = Primitive (Circle 5)

triangle : Picture
triangle = Primitive (Triangle 10 10)

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

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

picture_area : Picture -> Double
picture_area (Primitive shape) = area shape
picture_area (Combine pic pic1) = picture_area pic + picture_area pic1
picture_area (Rotate x pic) = picture_area pic
picture_area (Translate x y pic) = picture_area pic

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

%name Tree tree, tree1

insert : Ord a =>
         a -> Tree a -> Tree a
insert x Empty = Node Empty x Empty
insert x orig@(Node left y right) = case compare x y of
                                    LT => Node (insert x left) y right
                                    EQ => orig
                                    GT => Node left y (insert x right)

listToTree : Ord a => List a -> Tree a
listToTree xs = foldr insert Empty xs

foldrTree : (a -> as -> as) -> as -> Tree a -> as
foldrTree f x Empty = x
foldrTree f x (Node lft y rgt) = let rgt' = (foldrTree f x rgt) in
                                 foldrTree f (f y rgt') lft

treeToList : Tree a -> List a
treeToList tree = foldrTree (::) [] tree

data Expr = PrimInt Int
          | Add Expr Expr
          | Sub Expr Expr
          | Mult Expr Expr

evaluate : Expr -> Int
evaluate (PrimInt x) = x
evaluate (Add x y) = evaluate x + evaluate y
evaluate (Sub x y) = evaluate x - evaluate y
evaluate (Mult x y) = evaluate x * evaluate y

maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe Nothing x = x
maxMaybe x Nothing = x
maxMaybe (Just x) (Just y) = Just (max x y)

triangleSize : Shape -> Maybe Double
triangleSize tri@(Triangle _ _) = Just (area tri)
triangleSize _ = Nothing

biggestFound : Maybe Double -> Picture -> Maybe Double
biggestFound x (Primitive p) = maxMaybe x (triangleSize p)
biggestFound x (Combine pic pic1) = biggestFound (biggestFound x pic) pic1
biggestFound x (Rotate y pic) = biggestFound x pic
biggestFound x (Translate y z pic) = biggestFound x pic

biggestTriangle : Picture -> Maybe Double
biggestTriangle pic = biggestFound Nothing pic

data PowerSource = Petrol | Pedal

data Vehicle : PowerSource -> Type where
  Bicycle : Vehicle Pedal
  Unicycle : Vehicle Pedal
  Car : (fuel : Nat) -> Vehicle Petrol
  Bus : (fuel : Nat) -> Vehicle Petrol

wheels : Vehicle p -> Nat
wheels Bicycle = 2
wheels Unicycle = 1
wheels (Car fuel) = 4
wheels (Bus fuel) = 4

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Car 200


maybeAdd : Maybe Int -> Maybe Int -> Maybe Int
maybeAdd x y = case x of
                    Nothing => Nothing
                    Just x_val => case y of
                                       Nothing => Nothing
                                       Just y_val => Just (x_val + y_val)

maybeAdd' : Maybe Int -> Maybe Int -> Maybe Int
maybeAdd' x y = x >>= \x_val =>
                y >>= \y_val =>
                Just (x_val + y_val)

maybeAdd'' : Maybe Int -> Maybe Int -> Maybe Int
maybeAdd'' x y = do x_val <- x
                    y_val <- y
                    Just (x_val + y_val)


-- data MyNat = Z | S MyNat

-- Z
-- S Z
-- S (S Z)
-- S (S (S Z))

-- myPlus : MyNat -> MyNat -> MyNat
-- myPlus Z j = j
-- myPlus (S x) j = S (myPlus x j)


{-
 SnocList and fast reverse examples from 10.2.1 and 10.2.2
 "snoc" == reverse "cons"
 The book claims linear cost but my experiments suggest quadratic.
 I think the cost of snocListHelp append proofs causes it.
-}

module Part2.Sez10_2a_snoc

%default total

public export
data SnocList : List a -> Type where
     Empty : SnocList []
     Snoc : (rec : SnocList xs) -> SnocList (xs ++ [x])

export
snocList : (xs : List a) -> SnocList xs

snocListHelp : (snoc : SnocList input) -> (rest : List a) ->
               SnocList (input ++ rest)
snocListHelp {input} snoc [] = rewrite appendNilRightNeutral input in snoc
snocListHelp {input} snoc (x :: xs) = rewrite appendAssociative input [x] xs in
                     snocListHelp (Snoc snoc {x}) xs

snocList xs = snocListHelp Empty xs

||| reverse based on SnocList view, implementation that avoids using Helper function
export
myReverse : List a -> List a
-- with argument is not recreated in recursive step
myReverse input with (snocList input)
  myReverse [] | Empty = []
  myReverse (xs ++ [x]) | (Snoc rec) = x :: myReverse xs | rec -- passed with argument

test1 : List Int
test1 = myReverse [1..50]

test2 : List Int
test2 = myReverse [1..100]

{-
idris repl:
*Part2/Sec10_2a> myReverse [1..10]
[10, 9, 8, 7, 6, 5, 4, 3, 2, 1] : List Integer
*Part2/Sec10_2a> :t appendNilRightNeutral
appendNilRightNeutral : (l : List a) -> l ++ [] = l
*Part2/Sec10_2a> :t appendAssociative
appendAssociative : (l : List a) ->
                    (c : List a) -> (r : List a) -> l ++ c ++ r = (l ++ c) ++ r
-}


module Conway

import Data.Vect
import Data.Fin

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

board : Nat -> Nat -> Type
board n m = Vect n (Vect m Bool)

printChar : Bool -> String
printChar False = "x"
printChar True = "o"

printRow : Vect m Bool -> String
printRow [] = "\n"
printRow (x :: xs) = (printChar x) ++ (printRow xs)

printBoard : board n m -> String
printBoard = concat . map printRow

listFins : (n : Nat) -> Vect n (Fin n)
listFins Z = []
listFins (S k) = FZ :: (map FS (listFins k))

boardAux : Fin n -> Vect m (Fin n, Fin m)
boardAux {n} {m} f = map (\x => (f,x)) (listFins m)

boardCoords : (n : Nat) -> (m : Nat) -> Vect n (Vect m (Fin n, Fin m))
boardCoords n m = map boardAux (listFins n)

promote : Fin k ->  Fin (S k)
promote FZ = FZ
promote (FS x) = (FS (promote x))

safeDec : Fin n -> Fin n
safeDec FZ = FZ
safeDec (FS x) = promote x

maxFin : (n : Nat) -> Fin (S n)
maxFin Z = FZ
maxFin (S k) = FS (maxFin k)

-- this should return the maximum element in the finite set
safeInc : Fin n -> Fin n
safeInc {n = Z} FZ impossible
safeInc {n = Z} (FS _) impossible
safeInc {n = (S k)} f = case (strengthen f) of
                          Left same => same
                          Right f' => (FS f')

myStrengthen : Fin (S n) -> Either (Fin (S n)) (Fin n)
myStrengthen {n = Z} f = Left FZ
myStrengthen {n = (S k)} FZ = Right FZ
myStrengthen {n = (S k)} (FS x) = case (myStrengthen x) of
                                   Left same => Left (FS x)
                                   Right decked => Right (FS decked)

lastV : Vect (S n) a -> a
lastV (x :: []) = x
lastV (x :: (y :: xs)) = lastV (y :: xs)

filterV : (a -> Bool) -> Vect n a -> (m ** (Vect m a))
filterV f [] = (0 ** [])
filterV f (x :: xs) = case (f x) of
                       True => let (n ** xs') = filterV f xs in (S n ** (x :: xs'))
                       False => filterV f xs

nubV : Eq a => Vect n a -> (m ** (Vect m a))
nubV [] = (Z ** [])
nubV (x :: xs) = let (n ** xs') = filterV (\y => y /= x) xs
                     (n' ** xs'') = nubV xs'
                 in (S n' ** (x :: xs''))

neighCoords : Fin n -> Fin m -> List (Fin n, Fin m)
neighCoords fx fy = [(safeInc fx , fy),
                     (safeInc fx , safeInc fy),
                     (fx , safeInc fy),
                     (safeDec fx, safeInc fy),
                     (safeInc fx , safeDec fy),
                     (safeDec fx, fy),
                     (fx , safeDec fy),
                     (safeDec fx, safeDec fy)]

ixer : board n m -> (Fin n, Fin m) -> Lazy Bool
ixer b (fx, fy) = index fy (index fx b)

rhs : Vect n (Vect m (Fin n, Fin m)) -> (b : Vect n (Vect m Bool)) -> (Fin n, Fin m) -> Bool
rhs coords b f = let neigh = uncurry neighCoords f in and $ map (ixer b) neigh

gameStep : board n m -> board n m
gameStep {n} {m} b = let coords = boardCoords n m in map (map (rhs coords b)) coords

repeatF : Nat -> (a -> a) -> a -> a
repeatF Z f = id
repeatF (S k) f = f . (repeatF k f)

-- this is way too specific, but I'm getting bored
placeBoard : board n m -> Fin n -> Fin m -> board n m
placeBoard b fx fy = updateAt fx (\v => updateAt fy (const True) v) b

blankBoard : board n m
blankBoard {n} {m} = map (map (const False)) (boardCoords n m)

mkBoard : (List (Fin n, Fin m)) -> board n m
mkBoard l = foldr (\f,b => uncurry (placeBoard b) f) blankBoard l


import Data.Fin
import Data.Vect

tail : (Fin (S n) -> a) -> (Fin n -> a)
tail f = f . FS

toVectFun : {n : Nat} -> (Fin n -> a) -> Vect n a
toVectFun {n =   Z} _ = Nil
toVectFun {n = S m} f = (f FZ) :: (toVectFun (tail f))

N : Nat
N = 500

xs : Vect (S N) Nat
xs = toVectFun {n = S N} finToNat

main : IO ()
main = putStrLn $
  "xs(" ++ show N ++ ") = " ++ show (index (fromInteger (natToInteger N)) xs)


> data Vect : Nat -> Type -> Type where
>      Nil : Vect Z a
>      (::) : a -> Vect k a -> Vect (S k) a

> %name Vect xs, ys, zs

> append : Vect n a -> Vect m a -> Vect (n + m) a
> append xs ys
>     = case xs of
>            [] => ?bar_3
>            (x :: zs) => ?bar_4


> module SequentialDecisionProblems.examples.Main

> import Decidable.Order

> import Data.List
> import Data.List.Quantifiers
> import Effects
> import Effect.Exception
> import Effect.StdIO

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.FullTheory
> import SequentialDecisionProblems.Utils
> import SequentialDecisionProblems.NonDeterministicDefaults
> import SequentialDecisionProblems.CoreTheoryOptDefaults
> import SequentialDecisionProblems.FullTheoryOptDefaults
> import SequentialDecisionProblems.ViabilityDefaults

> import SequentialDecisionProblems.examples.LeftAheadRight

> import List.Operations
> import List.Properties
> import BoundedNat.BoundedNat
> import BoundedNat.Operations
> import BoundedNat.Properties
> import Sigma.Sigma
> import Nat.LTEProperties
> import Nat.LTProperties
> import Nat.OperationsProperties
> import LocalEffect.Exception
> import LocalEffect.StdIO

> -- %default total
> %auto_implicits off

> -- %logging 5

We reimplement "Example1.lidr", this time with |M = List|.

* The decision process:

> maxColumn : Nat
> maxColumn = 10

> nColumns : Nat
> nColumns = S maxColumn

** States:

> SequentialDecisionProblems.CoreTheory.State t = LTB nColumns

** Controls:

> SequentialDecisionProblems.CoreTheory.Ctrl t x = LeftAheadRight

** Transition function:

> SequentialDecisionProblems.CoreTheory.nexts t (MkSigma Z prf) Left =
>   [MkSigma maxColumn (ltIdS maxColumn)]
> SequentialDecisionProblems.CoreTheory.nexts t (MkSigma (S n) prf) Left =
>   [MkSigma n (ltLemma1 n nColumns prf)]
> SequentialDecisionProblems.CoreTheory.nexts t x Ahead = [x]
> SequentialDecisionProblems.CoreTheory.nexts t (MkSigma n prf) Right with (decLT n maxColumn)
>   | (Yes p)     = [MkSigma (S n) (LTESucc p)]
>   | (No contra) = [MkSigma  Z    (LTESucc LTEZero)]

** |Val| and |LTE|:

> SequentialDecisionProblems.CoreTheory.Val =
>   Nat

> SequentialDecisionProblems.CoreTheory.plus =
>   Prelude.Nat.plus

> SequentialDecisionProblems.CoreTheory.zero =
>   Z

> SequentialDecisionProblems.CoreTheory.LTE =
>   Prelude.Nat.LTE

> SequentialDecisionProblems.FullTheory.reflexiveLTE =
>   Nat.LTEProperties.reflexiveLTE

> SequentialDecisionProblems.FullTheory.transitiveLTE =
>   Nat.LTEProperties.transitiveLTE

> SequentialDecisionProblems.FullTheory.monotonePlusLTE =
>   Nat.LTEProperties.monotoneNatPlusLTE

> SequentialDecisionProblems.CoreTheoryOptDefaults.totalPreorderLTE =
>   Nat.LTEProperties.totalPreorderLTE

** Reward function:

> SequentialDecisionProblems.CoreTheory.reward t x y (MkSigma c _) =
>   if c == Z
>   then (S Z)
>   else if (S c) == nColumns
>        then (S (S Z))
>        else Z

** Measure:

> SequentialDecisionProblems.CoreTheory.meas = sum
> SequentialDecisionProblems.FullTheory.measMon = sumMon

** |Ctrl| is finite:

> SequentialDecisionProblems.Utils.finiteCtrl _ =
>   finiteLeftAheadRight

** Reachability

> SequentialDecisionProblems.CoreTheory.Reachable x' = Unit
> SequentialDecisionProblems.CoreTheory.reachableSpec1 {t} x r y = all (nexts t x y) where
>   all : (xs : List (State (S t))) -> SequentialDecisionProblems.CoreTheory.All (Reachable {t' = S t}) xs
>   all Nil = Nil
>   all (x :: xs) = () :: (all xs)

* The computation:

> SequentialDecisionProblems.Utils.showState = show @{ShowLTB}
> SequentialDecisionProblems.Utils.showCtrl = show

> computation : { [STDIO] } Eff ()
> computation =
>   do putStr ("enter number of steps:\n")
>      nSteps <- getNat
>      putStr ("enter initial column:\n")
>      x0 <- getLTB nColumns
>      case (decidableViable {t = Z} nSteps x0) of
>        (Yes v0) => do putStrLn ("computing optimal policies ...")
>                       ps   <- pure (backwardsInduction Z nSteps)
>                       putStrLn ("computing optimal controls ...")
>                       mxys <- pure (possibleStateCtrlSeqs x0 () v0 ps)
>                       putStrLn (show mxys)
>                       putStrLn ("done!")
>        (No _)   => putStrLn ("initial column non viable for " ++ cast {from = Int} (cast nSteps) ++ " steps")

> main : IO ()
> main = run computation

> {-

> ---}

-- Local Variables:
-- idris-packages: ("effects")
-- End:


module Average

export
average : String -> Double
average str = let numWords = wordCount str
                  totalLength = sum (allLengths (words str)) in
              cast totalLength / cast numWords
where
  wordCount : String -> Nat
  wordCount str = length (words str)

  allLengths : List String -> List Nat
  allLengths strs = map length strs


> module Vect.Operations

> import Data.Vect
> import Data.Fin
> import Data.So

> import Decidable.Predicates
> import Rel.TotalPreorder
> import Rel.TotalPreorderOperations
> import Nat.LTProperties
> import Sigma.Sigma

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

Lookup

> ||| Lookup the index of an element of a vector
> lookup : {A : Type} -> .(a : A) -> .(as : Vect n A) -> Elem a as -> Fin n
> lookup {n = Z}   a  Nil        Here         impossible
> lookup {n = Z}   a  Nil       (There p)     impossible
> lookup {n = S m} a (a :: as)   Here       = FZ
> lookup {n = S m} a (a' :: as) (There prf) = FS (lookup a as prf)

> ||| Lookup the index of an element of a vector
> -- lookup' : {n : Nat} -> {A : Type} -> (DecEq A) => (a : A) -> (as : Vect n A) -> Maybe (Fin n)
> lookup' : {n : Nat} -> {A : Type} -> (DecEq A) -> (a : A) -> (as : Vect n A) -> Maybe (Fin n)
> lookup' {n = Z}   _ _  Nil        = Nothing
> lookup' {n = S m} d a  (a' :: as) with (decEq a a')
>   | (Yes _) = Just FZ
>   | (No  _) with (lookup' d a as)
>     | Nothing  = Nothing
>     | (Just k) = Just (FS k)

Container monad operations

...

Filtering

> ||| Filters a vector on a decidable property
> filter : {A : Type} ->
>          {P : A -> Type} ->
>          Dec1 P ->
>          Vect n A ->
>          Sigma Nat (\ m => Vect m A)
> filter d1P Nil = MkSigma Z Nil
> filter d1P (a :: as) with (filter d1P as)
>   | (MkSigma n as') with (d1P a)
>     | (Yes _) = MkSigma (S n) (a :: as')
>     | (No  _) = MkSigma n as'

> ||| Filters a vector on a decidable property and pairs elements with proofs
> filterTagSigma : {A : Type} ->
>                  {P : A -> Type} ->
>                  Dec1 P ->
>                  Vect n A ->
>                  Sigma Nat (\ m => Vect m (Sigma A P))
> filterTagSigma d1P Nil = MkSigma _ Nil
> filterTagSigma d1P (a :: as) with (filterTagSigma d1P as)
>   | (MkSigma _ tail) with (d1P a)
>     | (Yes p) = MkSigma _ ((MkSigma a p) :: tail)
>     | (No  _) = MkSigma _ tail

> ||| Filters a vector on a decidable property and pairs elements with proofs
> filterTagExists : {A : Type} ->
>                   {P : A -> Type} ->
>                   Dec1 P ->
>                   Vect n A ->
>                   Sigma Nat (\ m => Vect m (Exists {a = A} P))
> filterTagExists d1P Nil = MkSigma _ Nil
> filterTagExists d1P (a :: as) with (filterTagExists d1P as)
>   | (MkSigma _ tail) with (d1P a)
>     | (Yes p) = MkSigma _ ((Evidence a p) :: tail)
>     | (No  _) = MkSigma _ tail

> ||| Filters a vector on a decidable property and pairs elements with proofs
> filterTagSubset : {A : Type} ->
>                   {P : A -> Type} ->
>                   Dec1 P ->
>                   Vect n A ->
>                   Sigma Nat (\ m => Vect m (Subset A P))
> filterTagSubset d1P Nil = MkSigma _ Nil
> filterTagSubset d1P (a :: as) with (filterTagSubset d1P as)
>   | (MkSigma _ tail) with (d1P a)
>     | (Yes p) = MkSigma _ ((Element a p) :: tail)
>     | (No  _) = MkSigma _ tail

Searching

> |||
> argmaxMax : {A : Type} -> {R : A -> A -> Type} ->
>             TotalPreorder R -> Vect n A -> .(LT Z n) -> (Fin n, A)
> argmaxMax {n = Z}       tp  Nil                p = absurd p
> argmaxMax {n = S Z}     tp (a :: Nil)          _ = (FZ, a)
> argmaxMax {n = S (S m)} tp (a' :: (a'' :: as)) _ with (argmaxMax tp (a'' :: as) (ltZS m))
>   | (k, max) with (totalPre tp a' max)
>     | (Left  _) = (FS k, max)
>     | (Right _) = (FZ, a')

> |||
> argmax : {A : Type} -> {R : A -> A -> Type} ->
>          TotalPreorder R -> Vect n A -> .(LT Z n) -> Fin n
> argmax tp as p = fst (argmaxMax tp as p)

> |||
> max : {A : Type} -> {R : A -> A -> Type} ->
>       TotalPreorder R -> Vect n A -> .(LT Z n) -> A
> max tp as p = snd (argmaxMax tp as p)

> {-

> |||
> argmaxMax : {A : Type} ->
>             TotalPreorder A -> Vect n A -> .(LT Z n) -> (Fin n, A)
> argmaxMax {n = Z}       tp  Nil                p = absurd p
> argmaxMax {n = S Z}     tp (a :: Nil)          _ = (FZ, a)
> argmaxMax {n = S (S m)} tp (a' :: (a'' :: as)) _ with (argmaxMax tp (a'' :: as) (ltZS m))
>   | (k, max) with (totalPre tp a' max)
>     | (Left  _) = (FS k, max)
>     | (Right _) = (FZ, a')

> |||
> argmax : {A : Type} ->
>          TotalPreorder A -> Vect n A -> .(LT Z n) -> Fin n
> argmax tp as p = fst (argmaxMax tp as p)

> |||
> max : {A : Type} ->
>       TotalPreorder A -> Vect n A -> .(LT Z n) -> A
> max tp as p = snd (argmaxMax tp as p)

> -}

Show

> implementation Show (Elem a as) where
>   show = show' where
>     show' : {n : Nat} -> {A : Type} -> {a : A} -> {as : Vect n A} -> Elem a as -> String
>     show'  Here     = "Here"
>     show' (There p) = "There" ++ show' p

Pointwise modify

> |||
> modifyVect : {n : Nat} -> {a : Type} ->
>              Vect n a -> Fin n -> a -> Vect n a
> modifyVect {n = Z}    Nil          k  _  = absurd k
> modifyVect {n = S m} (a :: as)  FZ    a' = a' :: as
> modifyVect {n = S m} (a :: as) (FS k) a' = a :: (modifyVect as k a')

Fold:

data Vect : Nat -> Type -> Type where
  Nil : Vect Z A
  Cons : A -> Vect n A -> Vect (S n) A

x0 : X 0
f  : A -> X n -> X (S n)

> foldVect : {X : Nat -> Type} ->
>            {A : Type} ->
>            X 0 ->
>            ((n : Nat) -> A -> X n -> X (S n)) ->
>            Vect n A ->
>            X n
> foldVect {n = Z} x0 f Nil = x0
> foldVect {n = S m} x0 f (a :: as) = f m a (foldVect x0 f as)

> {-

> |||
> argmaxMax : {A : Type} -> {TO : A -> A -> Type} -> Preordered A TO =>
>             Vect (S n) A -> (Fin (S n), A)
> argmaxMax     {n = Z}   (a :: Nil) = (FZ, a)
> argmaxMax {A} {n = S m} (a :: (a' :: as)) with (preorder a (snd (argmaxMax (a' :: as))))
>   | (Left  _) = (FS (fst ka), snd ka) where
>     ka : (Fin (S m), A)
>     ka = argmaxMax (a' :: as)
>   | (Right _) = (FZ, a)

> |||
> argmax : {A : Type} -> {TO : A -> A -> Type} -> Preordered A TO =>
>          Vect (S n) A -> Fin (S n)
> argmax = fst . argmaxMax

> |||
> max : {A : Type} -> {TO : A -> A -> Type} -> Preordered A TO =>
>       Vect (S n) A -> A
> max = snd . argmaxMax

> -}

> {-

> |||
> argmaxMax : {A, F : Type} -> {TO : F -> F -> Type} -> Ordered F TO =>
>             Vect (S n) (A,F) -> (A,F)
> argmaxMax {n = Z}   (af :: Nil) = af
> argmaxMax {n = S m} (af :: (af' :: afs)) with (order (snd af) (snd (argmaxMax (af' :: afs))))
>   | (Left  _) = argmaxMax (af' :: afs)
>   | (Right _) = af

> |||
> argmax : {A, F : Type} -> {TO : F -> F -> Type} -> Ordered F TO =>
>          Vect (S n) (A,F) -> A
> argmax = fst . argmaxMax

> |||
> max : {A, F : Type} -> {TO : F -> F -> Type} -> Ordered F TO =>
>       Vect (S n) (A,F) -> F
> max = snd . argmaxMax

> ---}

> ---}


module Eval

import Syntax

export
eval : Expression -> Integer
eval (Numeral i)    = i
eval (Plus   e1 e2) = (eval e1) + (eval e2)
eval (Minus  e1 e2) = (eval e1) - (eval e2)
eval (Times  e1 e2) = (eval e1) * (eval e2)
eval (Divide e1 e2) = (eval e1) `div` (eval e2) -- Note: a bit evil - will fail with RTS exception.
eval (Negate e)     = -(eval e)


> module FastSimpleProb.SimpleProb

> import Data.So

> import Double.Predicates
> import NonNegDouble.NonNegDouble
> import NonNegDouble.BasicOperations
> import NonNegDouble.Properties
> import List.Operations

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

> using implementation NumNonNegDouble
>   |||
>   data SimpleProb : Type -> Type where
>     MkSimpleProb : {A : Type} ->
>                    (aps : List (A, NonNegDouble)) ->
>                    Positive (toDouble (sumMapSnd aps)) ->
>                    SimpleProb A


module Injective

%default total

interface Injective (op : t -> t) where
  inj : (a : t) -> (b : t) -> op a = op b -> a = b

  inj' : {a : t} -> {b : t} -> op a = op b -> a = b
  inj' {a} {b} = inj a b

Injective S where
  inj = succInjective


module Linear.Types

public export
(-<>) : Type -> Type -> Type
(-<>) a b = (1 x : a) -> b

infixr 0 -<>

public export
void1 : Void -<> a
void1 x impossible

public export
interface LBifunctor f where
  bimap : (a -<> c) -> (b -<> d) -> f a b -<> f c d

namespace LPair

  public export
  0 fst : LPair a b -> a
  fst (x # y) = x

  public export
  0 snd : LPair a b -> b
  snd (x # y) = y

  public export
  0 surjPairing : (w : LPair a b) -> fst w # snd w = w
  surjPairing (x # y) = Refl

public export
LBifunctor LPair where
  bimap f g (x # y) = (f x) # (g y)

public export
data I : Type where
 Star : I

namespace Sigma1
  public export
  data Sigma1 : (a : Type) -> (b : a -> Type) -> Type where
    (#) : (1 x : a) -> (1 y : b x) -> Sigma1 a b

namespace Sigma0
  public export
  data Sigma0 : (a : Type) -> (b : a -> Type) -> Type where
    (#): (0 x : a) -> (1 y : b x) -> Sigma0 a b

  public export
  0 fst : Sigma0 a b -<> a
  fst (x # y) = x

  public export
  snd : (1 x : Sigma0 a b) -> b (fst x)
  snd (x # y) = y

public export
data Sum : (a : Type) -> (b : Type) -> Type where
  Inl : (1 x : a) -> Sum a b
  Inr : (1 y : b) -> Sum a b

public export
Uninhabited (Inl x = Inr y) where
  uninhabited p impossible

public export
LBifunctor Sum where
 bimap f g (Inl x) = Inl $ f x
 bimap f g (Inr y) = Inr $ g y

namespace With
  public export
  0 With : Type -> Type -> Type
  With a b = (1 x : Bool) -> if x then a else b

  public export
  bimap : (a -<> c) -> (b -<> d) -> With a b -<> With c d
  bimap f g x True  = f (x True)
  bimap f g x False = g (x False)

namespace DWith
  public export
  0 DWith : (a : Type) -> (b : a -> Type) -> Type
  DWith a b = Sigma0 a (\x => With (Sigma1 a (\z => z = x)) (b x))

  public export
  fstW : DWith a b -<> a
  fstW (_ # w) = let (z # Refl) = (w True) in z

  public export
  sndW : (1 w : DWith a b) -> b (fstW {b = b} w)
  sndW (x # w) = replace {p = b} (eq (x # w)) (w False)
  where
    eq : (w : DWith a b) -> fst w = fstW {b = b} w
    eq (x # w) with (w True)
      eq (z # w) | (z # Refl) = Refl


totalLen : List String -> Nat
totalLen xs = foldr (\elem, acc => length elem + acc ) 0 xs


module Proofs.TranslationInvarianceTheory

import Common.Util
import Specifications.TranslationInvariance
import Proofs.GroupTheory
import Proofs.GroupCancelationLemmas
import Symmetry.Opposite

%default total
%access export

infixl 8 #

composeOrder : {(#) : Binop s} -> {(<=) : Binrel s} ->
  PartiallyOrderedMagmaSpec (#) (<=) -> (a,b,c,d : s) ->
    a <= b -> c <= d -> a # c <= b # d
composeOrder spec a b c d ab cd =
  let pp = translationInvariantR spec a b c ab
      qq = translationInvariantL spec c d b cd
  in transitive (order spec) (a # c) (b # c) (b # d) pp qq

orderInverseL : {(#) : Binop s} -> {(<=) : Binrel s} ->
  PartiallyOrderedGroupSpec (#) e inv (<=) -> (a,b,c : s) ->
    a # c <= b -> c <= inv a # b
orderInverseL spec a b c given = rewrite sym o2 in o1 where
  o1 : inv a # (a # c) <= inv a # b
  o1 = translationInvariantL (invariantOrder spec) (a # c) b _ given
  o2 : inv a # (a # c) = c
  o2 = groupCancel1bis (group spec) a c

orderInverseR : {(#) : Binop s} -> {(<=) : Binrel s} ->
  PartiallyOrderedGroupSpec (#) e inv (<=) -> (a,b,c : s) ->
    a # c <= b -> a <= b # inv c
orderInverseR spec a b c = orderInverseL (opposite spec) c b a

inverseReversesOrder : {(#) : Binop s} ->
  PartiallyOrderedGroupSpec (#) _ inv leq ->
    leq a b -> inv b `leq` inv a
inverseReversesOrder spec {a} {b} given = rewriteRelation leq o3 o4 o2 where
  o1 : inv a # a `leq` inv a # b
  o1 = translationInvariantL (invariantOrder spec) _ _ (inv a) given
  o2 : inv a # a # inv b `leq` inv a # b # inv b
  o2 = translationInvariantR (invariantOrder spec) (inv a # a) (inv a # b) _ o1
  o3 : inv a # a # inv b = inv b
  o3 = groupCancel1 (group spec) a _
  o4 : inv a # b # inv b = inv a
  o4 = groupCancel3bis (group spec) _ b

groupInverseAndOrder : {(#) : Binop s} ->
  PartiallyOrderedGroupSpec (#) e inv leq -> (a,b : s) ->
    a `leq` b -> a # inv b `leq` e
groupInverseAndOrder spec a b given = rewrite sym o2 in o1 where
  o1 : a # inv b `leq` b # inv b
  o1 = translationInvariantR (invariantOrder spec) a b _ given
  o2 : b # inv b = e
  o2 = inverseR (group spec) b

invertNegative : {(<=) : Binrel s} ->
  PartiallyOrderedGroupSpec _ zero neg (<=) -> (a : s) ->
    a <= zero -> zero <= neg a
invertNegative spec a negative = rewrite sym o2 in o1 where
  o1 : neg zero <= neg a
  o1 = inverseReversesOrder spec negative
  o2 : neg zero = zero
  o2 = groupInverseNeutral (group spec)


toBit : Num i => Char -> Maybe i
toBit '0' = Just 0
toBit '1' = Just 1
toBit _ = Nothing

-- Return the number represented in binary as an initial segment of
-- the string (remembering that if a number begins 0, it's zero).
eatBinary : (Eq i, Num i) => String -> i
eatBinary = firstDigit . unpack where

  laterDigit : i -> List Char -> i
  laterDigit n [] = n
  laterDigit n (d :: ds) = let
    f : Maybe i -> i
    f Nothing = n
    f (Just a) = laterDigit (2*n + a) ds
    in f $ toBit d

  firstDigit : List Char -> i
  firstDigit [] = 0
  firstDigit (d :: ds) = let
    f : Maybe i -> i
    f Nothing = 0
    f (Just 0) = 0
    f (Just a) = laterDigit a ds
    in f $ toBit d


data BNat = BZ | O BNat | E BNat

bnat_ind : {0 p : BNat -> Type}
        -> p BZ
        -> ((bn : BNat) -> p bn -> p (O bn))
        -> ((bn : BNat) -> p bn -> p (E bn))
        -> (bn : BNat) -> p bn
bnat_ind pbz po pe = go
 where
  go : (bn : BNat) -> p bn
  go BZ = ?pbz_hole
  go (O x) = po x (go x)
  go (E x) = pe x (go x)


import Aoc
import Data.Fin
import Data.List
import Data.List1
import Data.Nat
import Data.Strings
import Data.Vect
%default total

Passport : Type
Passport = List (String, String)

||| Split a string at the first colon in it: "abc:def" -> ("abc", "def").
splitColon : String -> (String, String)
splitColon s = let (p, q) = break (==':') s in (p, pack $ drop 1 $ unpack q)

requiredFields : List String
requiredFields = ["byr","iyr","eyr","hgt","hcl","ecl","pid"] -- not "cid"

||| *: Are all required fields present?
isValid1 : Passport -> Bool
isValid1 passport =
  all (\k => any ((==k) . fst) passport) requiredFields

||| Check if a string represents a natural number in a given range [lo, hi].
isNatInRange : Nat -> Nat -> String -> Bool
isNatInRange lo hi s =
  case parsePositive s of
    Nothing => False
    Just n => n >= lo && n <= hi

||| Validate a passport field.
isValidField : (String, String) -> Bool
isValidField (k, v) =
  case k of
    "byr" => isNatInRange 1920 2002 v
    "iyr" => isNatInRange 2010 2020 v
    "eyr" => isNatInRange 2020 2030 v
    "hgt" =>
      case span isDigit v of
        (n, "cm") => isNatInRange 150 193 n
        (n, "in") => isNatInRange 59 76 n
        _ => False
    "hcl" =>
      case unpack v of
        ('#'::xs) => length xs == 6 && all isLowerHexDigit xs
        _ => False
    "ecl" => Prelude.elem v ["amb","blu","brn","gry","grn","hzl","oth"]
    "pid" => let xs = unpack v in length xs == 9 && all isDigit xs
    "cid" => True
    _ => False

||| **: Are all required field present, and are all fields valid?
isValid2 : Passport -> Bool
isValid2 passport =
  isValid1 passport && all isValidField passport

partial
main : IO ()
main = do
  paras <- readParagraphs
  let passports = map (map splitColon . words . unwords) paras
  putStr "*   "; printLn (count isValid1 passports)
  putStr "**  "; printLn (count isValid2 passports)


module Entscheidbar

data Entscheidbar : (behauptung:Type) -> Type where
  Ja : (beweis : behauptung) -> Entscheidbar behauptung
  Nein : (widerspruch : behauptung -> Void) -> Entscheidbar behauptung

NullUngleichNachfolger : Nat -> (Z = S k) -> Void
NullUngleichNachfolger _ Refl impossible

NachfolgerUngleichNull : Nat -> (S k = Z) -> Void
NachfolgerUngleichNull _ Refl impossible

auchNichtGleich : (a = b -> Void) -> (S a = S b) -> Void
auchNichtGleich wid Refl = wid Refl

sindGleich : (n : Nat) -> (m : Nat) -> Entscheidbar (n = m)
sindGleich Z Z = Ja Refl
sindGleich Z (S k) = Nein (NullUngleichNachfolger k)
sindGleich (S k) Z = Nein (NachfolgerUngleichNull k)
sindGleich (S k) (S j) =
  case sindGleich k j of
    Ja prf => Ja (cong prf)
    Nein wid => Nein (auchNichtGleich wid)

sindGleich' : (n : Nat) -> (m : Nat) -> Dec (n = m)
sindGleich' Z Z = Yes Refl
sindGleich' Z (S k) = No (NullUngleichNachfolger k)
sindGleich' (S k) Z = No (NachfolgerUngleichNull k)
sindGleich' (S k) (S j) =
  case sindGleich' k j of
    Yes prf => Yes (cong prf)
    No wid => No (auchNichtGleich wid)


module Crypto.Hash.SHA1

import Crypto.Hash.Interfaces
import Data.Bits
import Data.DPair
import Data.Fin
import Data.Fin.Extra
import Data.List
import Data.Nat
import Data.Nat.Factor
import Data.Vect
import Utils.Misc
import Utils.Bytes
import Data.Stream
import Crypto.Hash.MerkleDamgard

export
data Sha1 : Type where
  MkSha1 : MerkleDamgard 5 64 Bits32 -> Sha1

sha1_init_hash_values : Vect 5 Bits32
sha1_init_hash_values =
  [ 0x67452301, 0xEFCDAB89, 0x98BADCFE, 0x10325476, 0xC3D2E1F0 ]

sha1_extend_message : Vect 16 Bits32 -> Stream Bits32
sha1_extend_message xs = prepend (toList xs) $ go xs
  where
  go : Vect 16 Bits32 -> Stream Bits32
  go xs =
    let
      [wi_16, wi_14, wi_8, wi_3] = the (Vect 4 _) $ map (flip index xs) [0, 2, 8, 13]
      w = rotl 1 (wi_16 `xor` wi_14 `xor` wi_8 `xor` wi_3)
    in
      w :: go (tail xs `snoc` w)

sha1_compress : (block : Vect 64 Bits8) -> (h : Vect 5 Bits32) -> Vect 5 Bits32
sha1_compress block hash_values = zipWith (+) hash_values $ go Z (sha1_extend_message $ map (from_be {a = Bits32} {n = 4}) $ group 16 4 block) hash_values
  where
  loop : Bits32 -> Bits32 -> Bits32 -> Bits32 -> Bits32 -> Bits32 -> Bits32 -> Bits32 -> Vect 5 Bits32
  loop f k wi a b c d e =
    let temp = (rotl 5 a) + f + e + k + wi
        e = d
        d = c
        c = rotl 30 b
        b = a
        a = temp
    in [a, b, c, d, e]
  go :  Nat -> Stream Bits32 -> Vect 5 Bits32 -> Vect 5 Bits32
  go n (wi :: ws) abc@[a, b, c, d, e] =
    case n `div` 20 of
      0 => go (S n) ws $ loop ((b .&. c) .|. ((complement b) .&. d))  0x5A827999 wi a b c d e
      1 => go (S n) ws $ loop (b `xor` c `xor` d)                     0x6ED9EBA1 wi a b c d e
      2 => go (S n) ws $ loop ((b .&. c) .|. (b .&. d) .|. (c .&. d)) 0x8F1BBCDC wi a b c d e
      3 => go (S n) ws $ loop (b `xor` c `xor` d)                     0xCA62C1D6 wi a b c d e
      _ => abc

sha1_update : List Bits8 -> Sha1 -> Sha1
sha1_update input (MkSha1 s) =
  let
    Fraction _ 64 nblocks residue_nbyte prf = divMod (s.buffer_nbyte + length input) 64
    (blocks, residue) = splitAt (mult nblocks 64) (replace_vect (sym prf) (s.buffer ++ fromList input))
  in
    MkSha1 $ {buffer := residue, buffer_nbyte := _, buffer_nbyte_constraint := elemSmallerThanBound residue_nbyte }
      ( foldl (\s_, block_ => {hash_values $= sha1_compress block_, npassed_blocks $= S} s_) s (group nblocks 64 blocks) )

sha1_finalize : Sha1 -> Vect 20 Bits8
sha1_finalize (MkSha1 s) =
  concat $ map (to_be {n = 4}) $
    case pad_theorem {block_nbyte = 64} {residue_max_nbyte = 55} {length_nbyte = 8} (LTESucc LTEZero) Refl s.buffer_nbyte_constraint s.buffer (integer_to_be _ $ 8 * (cast s.npassed_blocks * 64 + cast s.buffer_nbyte)) of
      Left block => sha1_compress block s.hash_values
      Right blocks => let (x1, x2) = splitAt 64 blocks in sha1_compress x2 $ sha1_compress x1 s.hash_values

export
Digest Sha1 where
  digest_nbyte = 20
  update = sha1_update
  finalize = sha1_finalize

export
Hash Sha1 where
  block_nbyte = 64
  initialize = MkSha1 $ mk_merkle_damgard sha1_init_hash_values


module Chapter3

import Data.Vect

invert : Bool -> Bool
invert False = True
invert True = False

describe_list : List Int -> String
describe_list [] = "Empty List"
describe_list (x :: xs) = "Non-empty, tail = " ++ show xs

word_lengths : List String -> List Nat
word_lengths [] = []
word_lengths (word :: words) = length word :: word_lengths words

xor : Bool -> Bool -> Bool
xor False y = y
xor True y = not y

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

  isOdd : Nat -> Bool
  isOdd Z = False
  isOdd (S k) = isEven k

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

word_lengths_vec : Vect len String -> Vect len Nat
word_lengths_vec [] = []
word_lengths_vec (word :: words) = length word :: word_lengths_vec words

insert : Ord elem => (x : elem) -> (xs_sorted : Vect k elem) -> Vect (S k) elem
insert x [] = [x]
insert x (y :: xs) =  if x < y then x :: y :: xs
                               else y :: insert x xs

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

list_length : List a -> Nat
list_length [] = 0
list_length (x :: xs) = 1 + list_length xs

list_reverse : List a -> List a
list_reverse [] = []
list_reverse (x :: xs) = (list_reverse xs) ++ [x]

list_map : (a -> b) -> List a -> List b
list_map _ [] = []
list_map f (x :: xs) = f x :: list_map f xs

vec_map : (a -> b) -> Vect n a -> Vect n b
vec_map _ [] = []
vec_map f (x :: xs) = f x :: vec_map f xs