module Main

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

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

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

Resolution1D : Nat
Resolution1D = 10

Tiling : Type
Tiling = Vect Resolution1D $ Vect Resolution1D Bool

tilingOrientations : Tiling -> Vect 16 Tiling
tilingOrientations tiling = concat $ tilingRotations <$> tilingFlippings tiling where
  tilingFlippings : Tiling -> Vect 4 Tiling
  tilingFlippings tiling =
    [ tiling
    , reverse tiling
    , reverse <$> tiling
    , reverse <$> reverse tiling
    ]
  tilingRotations : Tiling -> Vect 4 Tiling
  tilingRotations tiling =
    [ tiling
    , rotate90 tiling
    , rotate90 $ rotate90 tiling
    , rotate90 $ rotate90 $ rotate90 tiling
    ] where
      rotate90 : Tiling -> Tiling
      rotate90 = reverse . transpose

record Tile where
  constructor MkTile
  id : Nat
  tiling : Tiling

Show Tile where
  show (MkTile id tiling) = "Tile " ++ show id ++ " " ++ show tiling

TilingMap : Type
TilingMap = SortedMap Nat Tiling

createTilingMap : List Tile -> TilingMap
createTilingMap = fromList . map f where
  f : Tile -> (Nat, Tiling)
  f (MkTile id tiling) = (id, tiling)

-- from square root of `length tiles`
Resolution1DImage : Nat
Resolution1DImage = 12

Arrangement : Type
Arrangement = Vect Resolution1DImage $ Vect Resolution1DImage $ Maybe Nat

nextCoordinate : {n : Nat} -> (x : Fin $ S n) -> Fin $ S n
nextCoordinate x with (strengthen x)
  nextCoordinate x | (Left y) = FZ
  nextCoordinate x | (Right y) = FS y

nextCoordinates : {n : Nat} ->
                  (x : Fin n) ->
                  (y : Fin n) ->
                  Maybe (Fin n, Fin n)
nextCoordinates x y with (n)
  nextCoordinates x y | Z = Nothing
  nextCoordinates x y | (S k) =
    if x == last
       then if y == last
               then Nothing
               else Just (FZ, nextCoordinate y)
       else Just (nextCoordinate x, nextCoordinate y)

data Direction = DirectionLeft
               | DirectionUp

neighborsToCheck : {n : Nat} ->
                   (x : Fin n) ->
                   (y : Fin n) ->
                   List ((Fin n, Fin n), Direction)
neighborsToCheck x y = [ ((pred x, y), DirectionUp), ((x, pred y), DirectionLeft) ] where
  pred : {n : Nat} -> (x : Fin n) -> Fin n
  pred FZ = last -- this is additional and not necessary, but allows returning Vect
  pred (FS k) = weaken k

neighborsToCheck' : (arrangement : Arrangement) ->
                    (x : Fin Resolution1DImage) ->
                    (y : Fin Resolution1DImage) ->
                    List (Nat, Direction)
neighborsToCheck' arrangement x y = do
  ((x', y'), d') <- neighborsToCheck x y
  let n = index x' $ index y' arrangement
  case n of
       Nothing => []
       Just n' => pure (n', d')

checkTiling : Direction -> (new : Tiling) -> (old : Tiling) -> Bool
checkTiling DirectionLeft new old = (index last <$> old) == (index FZ <$> new)
checkTiling DirectionUp new old = index last old == index FZ new

checkNeighbors : (tilingMap : TilingMap) ->
                 (new : Tiling) ->
                 List (Nat, Direction) ->
                 Bool
checkNeighbors tilingMap new [] = True
checkNeighbors tilingMap new ((n, d) :: xs) =
  case lookup n tilingMap of
       Nothing => ?keysShouldMatch
       Just old => if checkTiling d new old
                      then checkNeighbors tilingMap new xs
                      else False

checkNeighbors' : (tilingMap : TilingMap) ->
                  (arrangement : Arrangement) ->
                  (new : Tiling) ->
                  (x : Fin Resolution1DImage) ->
                  (y : Fin Resolution1DImage) ->
                  Bool
checkNeighbors' tilingMap arrangement new x y =
  checkNeighbors tilingMap new $ neighborsToCheck' arrangement x y

filterTilings : (tilingMap : TilingMap) ->
                (arrangement : Arrangement) ->
                (tilings : List (Nat, Tiling)) ->
                (x : Fin Resolution1DImage) ->
                (y : Fin Resolution1DImage) ->
                List (Nat, Tiling)
filterTilings tilingMap arrangement tilings x y =
  filter (\(_,t) => checkNeighbors' tilingMap arrangement t x y) tilings

tryTilings : (tilingMap : TilingMap) ->
             (arrangement : Arrangement) ->
             (x : Fin Resolution1DImage) ->
             (y : Fin Resolution1DImage) ->
             List Arrangement
tryTilings tilingMap arrangement x y = ?tryTilings_rhs where
  tilingsToTry : List (Nat, Tiling)
  tilingsToTry = do
    (n, t) <- Data.SortedMap.toList tilingMap
    t' <- toList $ tilingOrientations t
    pure (n, t')
  possibleTilings : List (Nat, Tiling)
  possibleTilings = filterTilings tilingMap arrangement tilingsToTry x y
  nextTry : (Nat, Tiling) -> List Arrangement
  nextTry (n, t) = case nextCoordinates x y of
                        Nothing => pure newArrangement
                        Just (x',y') => tryTilings newTilingMap newArrangement x' y'
                        where
                          newTilingMap : TilingMap
                          newTilingMap = insert n t tilingMap
                          newArrangement : Arrangement
                          newArrangement = replaceAt y (replaceAt x (Just n) $ index y arrangement) arrangement

findTilings : (tilingMap : TilingMap) ->
              List Arrangement
findTilings tilingMap = tryTilings tilingMap (pure $ pure Nothing) FZ FZ

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

namespace Parsing

  data DataKind = DKTile
                | DKSpace
                | DKNum
                | DKColon
                | DKNewline
                | DKDot
                | DKHash

  Eq DataKind where
    DKTile == DKTile = True
    DKSpace == DKSpace = True
    DKNum == DKNum = True
    DKColon == DKColon = True
    DKNewline == DKNewline = True
    DKDot == DKDot = True
    DKHash == DKHash = True
    _ == _ = False

  TokenKind DataKind where
    TokType DKNum = Nat
    TokType _ = ()
    tokValue DKNum x = integerToNat $ cast x
    tokValue DKTile _ = ()
    tokValue DKSpace _ = ()
    tokValue DKColon _ = ()
    tokValue DKNewline _ = ()
    tokValue DKDot _ = ()
    tokValue DKHash _ = ()

  tokenMap : TokenMap $ Token DataKind
  tokenMap = toTokenMap
    [ (digits, DKNum)
    , (is '.', DKDot)
    , (is '#', DKHash)
    , (exact "Tile", DKTile)
    , (newline, DKNewline)
    , (space, DKSpace)
    , (is ':', DKColon)
    ]

  countExactly : (n : Nat) -> (p : Grammar tok True a) -> Grammar tok (isSucc n) (Vect n a)
  countExactly Z p = Empty []
  countExactly (S k) p = [| p :: countExactly k p |]

  grammarTiles : Grammar (Token DataKind) True (List Tile)
  grammarTiles = sepBy1 (match DKNewline) grammarTile where
    grammarPixel : Grammar (Token DataKind) True Bool
    grammarPixel = match DKDot $> False <|> match DKHash $> True
    grammarTiling : Grammar (Token DataKind) True Tiling
    grammarTiling =
      countExactly Resolution1D $ countExactly Resolution1D grammarPixel <* match DKNewline
    grammarTile : Grammar (Token DataKind) True Tile
    grammarTile = do
      match DKTile
      match DKSpace
      id <- match DKNum
      match DKColon
      match DKNewline
      tiling <- grammarTiling
      pure $ MkTile id tiling

  export
  readData : String -> Maybe $ List Tile
  readData str = do
    let (tokens, debugLexed) = lex tokenMap str
        parsed = parse grammarTiles $ tok <$> tokens
    case parsed of
         Left _ => Nothing
         Right (rule, _) => Just rule

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

main : IO ()
main = do
  inputData <- readFile "./data"
  case inputData of
       Left err => print err
       Right dat => do
         case readData dat of
              Nothing => pure ()
              Just tiles => do
                let tilingMap = createTilingMap tiles
                print $ findTilings tilingMap
  pure ()


data DoorState = DoorClosed | DoorOpen

data DoorCmd : Type ->
               DoorState ->
               DoorState ->
               Type where
  Open : DoorCmd () DoorClosed DoorOpen
  Close : DoorCmd () DoorOpen DoorClosed
  RingBell : DoorCmd () DoorClosed DoorClosed

  Pure : ty -> DoorCmd ty state state
  (>>=) : DoorCmd a state1 state2 ->
       (a -> DoorCmd b state2 state3) ->
       DoorCmd b state1 state3

doorProg : DoorCmd () DoorClosed DoorClosed
doorProg = do RingBell
              Open
              Close

{-doorProgBad : DoorCmd ()
doorProgBad = do Open
                 Open
                 RingBell-}


module Data.Time.LocalTime.Internal.LocalTime

import Data.Time.Calendar.Days
import Data.Time.Calendar.Gregorian
import Data.Time.Clock.DiffTime
import Data.Time.Clock.Internal.UTCTime
import Data.Time.LocalTime.TimeZone
import Data.Time.LocalTime.TimeOfDay

import Generics.Derive

%default total
%language ElabReflection

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

||| A simple day and time aggregate, where the day is of the specified parameter,
||| and the time is a TimeOfDay.
||| Conversion of this (as local civil time) to UTC depends on the time zone.
||| Conversion of this (as local mean time) to UT1 depends on the longitude.
public export
record LocalTime where
  constructor MkLocalTime
  localDay : Day
  localTimeOfDay : TimeOfDay
%runElab derive "LocalTime" [Generic, Eq, Ord, DecEq]

public export
Show LocalTime where
  show x = show x.localDay ++ " " ++ show x.localTimeOfDay

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

||| Get the local time of a UTC time in a time zone.
export utcToLocalTime : TimeZone -> UTCTime -> LocalTime
utcToLocalTime tz (MkUTCTime day dt) = let
  (i, tod) = utcToLocalTimeOfDay tz (timeToTimeOfDay dt)
  in MkLocalTime (addDays i day) tod

||| Get the UTC time of a local time in a time zone.
export localTimeToUTC : TimeZone -> LocalTime -> UTCTime
localTimeToUTC tz (MkLocalTime day tod) = let
  (i, todUTC) = localToUTCTimeOfDay tz tod
  in MkUTCTime (addDays i day) (timeOfDayToTime todUTC)

-- --------------------------------------------------------------------------
-- vim: tw=80 sw=2 expandtab :


import Control.Monad.Identity

%default total

-- Validated - an Either with a monoidal error --

public export
data Validated e a = Valid a | Invalid e

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

export
(Show e, Show a) => Show (Validated e a) where
  showPrec d $ Valid   x = showCon d "Valid" $ showArg x
  showPrec d $ Invalid e = showCon d "Invalid" $ showArg e

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

public export
Bifunctor Validated where
  bimap _ s $ Valid x   = Valid   $ s x
  bimap f _ $ Invalid e = Invalid $ f e

-- Composition preserves invalidity
public export
Semigroup e => Applicative (Validated e) where
  pure = Valid

  Valid f    <*> Valid x    = Valid $ f x
  Invalid e1 <*> Invalid e2 = Invalid $ e1 <+> e2
  Invalid e  <*> Valid _    = Invalid e
  Valid _    <*> Invalid e  = Invalid e

-- Composition preserves validity
public export
Semigroup e => Semigroup (Validated e a) where
  l@(Valid _) <+> _           = l
  _           <+> r@(Valid _) = r
  Invalid e1  <+> Invalid e2  = Invalid $ e1 <+> e2

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

-- Composition preserves validity
public export
Monoid e => Alternative (Validated e) where
  empty = neutral
  (<|>) = (<+>)

public export
Foldable (Validated e) where
  foldr op init $ Valid x   = x `op` init
  foldr _  init $ Invalid _ = init

  foldl op init $ Valid x   = init `op` x
  foldl _  init $ Invalid _ = init

  null $ Valid _   = False
  null $ Invalid _ = True

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

public export %inline
ValidatedL : Type -> Type -> Type
ValidatedL e a = Validated (List e) a

public export %inline
oneInvalid : e -> Applicative f => Validated (f e) a
oneInvalid x = Invalid $ pure x

public export %inline
fromEither : Either e a -> Validated e a
fromEither $ Right x = Valid x
fromEither $ Left  e = Invalid e

public export %inline
fromEitherL : Either e a -> ValidatedL e a
fromEitherL $ Right x = Valid x
fromEitherL $ Left  e = oneInvalid e

public export %inline
toEither : Validated e a -> Either e a
toEither $ Valid   x = Right x
toEither $ Invalid e = Left e

-- Errorful monadic functions --

f1 : Monad m => Int -> m $ ValidatedL String Int
f1 5 = pure $ pure 0
f1 _ = pure $ oneInvalid "fail 1"

f2 : Monad m => Int -> m $ ValidatedL String Int
f2 6 = pure $ pure 0
f2 _ = pure $ oneInvalid "fail 2"

-- Compositions --

c1 : Monad m => m (ValidatedL String Int)
c1 = f1 1 *> f2 1

c2 : Monad m => m (ValidatedL String Int)
c2 = (f1 1 *> f2 1) @{Applicative.Compose}

-- These checks are meant to be true --

r1 : Bool
r1 = runIdentity c1 == Invalid ["fail 2"]

r2 : Bool
r2 = runIdentity c2 == Invalid ["fail 1", "fail 2"]


-- DataStore.idr
--
-- A simple Vect-based data store with
-- integer key and string values

module Main

import Data.Vect

infix 5 .+.

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

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

||| A record-style DataStore type
record DataStore where
       constructor MkData
       schema : Schema
       size : Nat
       items : Vect size (SchemaType schema)

{-
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)

||| commands for data store
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" str = Just (Search str)
parseCommand "size" "" = Just Size
parseCommand "quit" "" = Just Quit
parseCommand _ _ = Nothing

||| Parses given string and returns matching command
||| if sucessful (or Nothing in case of invalid string)
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)

findEntriesString : (idx : Nat) -> (str : String) -> (items : Vect len String) -> String
findEntriesString idx str [] = "\n"
findEntriesString idx str (x :: xs) = if (isInfixOf str x)
                                         then (show idx) ++ ": " ++ x ++ "\n" ++ findEntriesString (idx + 1) str xs
                                         else findEntriesString (idx + 1) str xs

findEntries : (str : String) -> (store : DataStore) -> String
findEntries str store = findEntriesString Z str (items store)

concatStringVect : (p : Nat ** Vect p (Nat, String)) -> String
concatStringVect (Z ** []) = "\n"
concatStringVect (S x ** ((id, str) :: items)) = (show id) ++ ": " ++ str ++ "\n" ++ concatStringVect (x ** items)

||| Processes given String command
processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input = case parse input of
                                Nothing => Just ("Unknown command: " ++ input ++ "\n", store)
                                Just (Add item) =>
                                  Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
                                Just (Get pos) => getEntry pos store
                                Just (Search str) =>
                                  Just (findEntries str store, store)
                                Just Size =>
                                  Just ("Size: " ++ cast (size store) ++ "\n", store)
                                Just Quit => Nothing

-- entry point
main : IO ()
main = replWith (MkData 0 []) "Command: " processInput

-}


twoPlusTwoNotFive : 2 + 2 = 5 -> Void
twoPlusTwoNotFive Refl impossible


module LazyListTrav

import Data.List.Lazy

import Debug.Trace

%default total

public export
Traversable LazyList where
  traverse = map force .: tr where
    tr : (a -> f b) -> LazyList a -> f (Lazy (LazyList b))
    tr g [] = pure []
    tr g (x::xs) = [| g x :: tr g xs |] where
      (::) : forall a. a -> Lazy (LazyList a) -> Lazy (LazyList a)
      (::) x xs = delay $ Lazy.(::) x xs

debugList : Nat -> LazyList Nat
debugList n = iterateN n f 1 where
  f : Nat -> Nat
  f x = trace "arg: \{show x}" $ x + 1

d : Applicative f => f $ LazyList Nat
d = map (Lazy.take 3) $ traverse pure $ debugList 500


module Arith

import Data.Primitives.Views

public export
randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
                   (seed' `shiftR` 2) :: randoms seed'
public export
arithInputs : Int -> Stream Int
arithInputs seed = map bound (randoms seed)
  where bound : Int -> Int
        bound x with (divides x 12)
          bound ((12 * div) + rem) | (DivBy prf) = rem + 1

quiz : Stream Int -> (score : Nat) -> IO ()
quiz (n1 :: n2 :: ns) score =
     do putStrLn $ "Thy score: " ++ show score
        putStr $ show n1 ++ " * " ++ show n2 ++ "? "
        answer <- getLine
        if cast answer == n1 * n2
           then putStrLn "Correct" >>= \_ => quiz ns $ score + 1
           else putStrLn ("Wrong. Answer is: " ++ show (n1 * n2)) >>= \_ => quiz ns score

-- 11.1 Ex. # 1
every_other : Stream ty -> Stream ty
every_other (v1 :: v2 :: vs) = v2 :: every_other vs


||| [specification](http://csrc.nist.gov/publications/fips/fips180-4/fips-180-4.pdf)
module Data.Crypto.Hash.SHS

import Data.Bits
import Data.Crypto.Hash
import Data.Crypto.Util
import Data.Fin
import Data.Mod
import Data.Vect

-- Functions

ch : Bits n -> Bits n -> Bits n -> Bits n
ch x y z = (x `and` y) `xor` (complement x `and` z)

parity : Bits n -> Bits n -> Bits n -> Bits n
parity x y z = (x `xor` y) `xor` z

maj : Bits n -> Bits n -> Bits n -> Bits n
maj x y z = ((x `and` y) `xor` (x `and` z)) `xor` (y `and` z)

f : Fin 80 -> Bits 32 -> Bits 32 -> Bits 32 -> Bits 32
f t = if t <= 19 then ch
 else if t <= 39 then parity
 else if t <= 59 then maj
                 else parity

Σ256_0 : Bits 32 -> Bits 32
Σ256_0 x = (rotateRight 2 x `xor` rotateRight 13 x) `xor` rotateRight 22 x

Σ256_1 : Bits 32 -> Bits 32
Σ256_1 x = (rotateRight 6 x `xor` rotateRight 11 x) `xor` rotateRight 25 x

σ256_0 : Bits 32 -> Bits 32
σ256_0 x = (rotateRight 7 x `xor` rotateRight 18 x) `xor` shiftRightLogical x (intToBits 3)

σ256_1 : Bits 32 -> Bits 32
σ256_1 x = (rotateRight 17 x `xor` rotateRight 19 x) `xor` shiftRightLogical x (intToBits 10)

Σ512_0 : Bits 64 -> Bits 64
Σ512_0 x = (rotateRight 28 x `xor` rotateRight 34 x) `xor` rotateRight 39 x

Σ512_1 : Bits 64 -> Bits 64
Σ512_1 x = (rotateRight 14 x `xor` rotateRight 18 x) `xor` rotateRight 41 x

σ512_0 : Bits 64 -> Bits 64
σ512_0 x = (rotateRight 1 x `xor` rotateRight 8 x) `xor` shiftRightLogical x (intToBits 7)

σ512_1 : Bits 64 -> Bits 64
σ512_1 x = (rotateRight 19 x `xor` rotateRight 61 x) `xor` shiftRightLogical x (intToBits 6)

-- Constants

const1 : Vect 80 (Bits 32)
const1 = concat (map (replicate 20 . intToBits)
                     [0x5a827999, 0x6ed9eba1, 0x8f1bbcdc, 0xca62c1d6])

const256 : Vect 64 (Bits 32)
const256 = map intToBits
               [0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5, 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,
                0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3, 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174,
                0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc, 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da,
                0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7, 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967,
                0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13, 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85,
                0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3, 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070,
                0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5, 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3,
                0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208, 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2]

const512 : Vect 80 (Bits 64)
const512 = map intToBits
               [0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f, 0xe9b5dba58189dbbc,
                0x3956c25bf348b538, 0x59f111f1b605d019, 0x923f82a4af194f9b, 0xab1c5ed5da6d8118,
                0xd807aa98a3030242, 0x12835b0145706fbe, 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2,
                0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235, 0xc19bf174cf692694,
                0xe49b69c19ef14ad2, 0xefbe4786384f25e3, 0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65,
                0x2de92c6f592b0275, 0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5,
                0x983e5152ee66dfab, 0xa831c66d2db43210, 0xb00327c898fb213f, 0xbf597fc7beef0ee4,
                0xc6e00bf33da88fc2, 0xd5a79147930aa725, 0x06ca6351e003826f, 0x142929670a0e6e70,
                0x27b70a8546d22ffc, 0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed, 0x53380d139d95b3df,
                0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6, 0x92722c851482353b,
                0xa2bfe8a14cf10364, 0xa81a664bbc423001, 0xc24b8b70d0f89791, 0xc76c51a30654be30,
                0xd192e819d6ef5218, 0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8,
                0x19a4c116b8d2d0c8, 0x1e376c085141ab53, 0x2748774cdf8eeb99, 0x34b0bcb5e19b48a8,
                0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb, 0x5b9cca4f7763e373, 0x682e6ff3d6b2b8a3,
                0x748f82ee5defb2fc, 0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec,
                0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915, 0xc67178f2e372532b,
                0xca273eceea26619c, 0xd186b8c721c0c207, 0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178,
                0x06f067aa72176fba, 0x0a637dc5a2c898a6, 0x113f9804bef90dae, 0x1b710b35131c471b,
                0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc, 0x431d67c49c100d4c,
                0x4cc5d4becb3e42b6, 0x597f299cfc657e2a, 0x5fcb6fab3ad6faec, 0x6c44198c4a475817]

-- Preprocessing

pad512 : Bits l -> Bits ((div l 512 + 1) * 512)
pad512 {l=l} message = append message
                              (append (intToBits 1)
                                      (append (the (Bits (modToNat (the (Mod 512) (448 - (natToMod l + 1))))) (intToBits 0))
                                              (the (Bits 64) (intToBits (cast l)))))

pad1024 : Bits l -> Bits ((div l 1024 + 1) * 1024)
pad1024 {l=l} message = append message
                               (append (intToBits 1)
                                       (append (the (Bits (modToNat (the (Mod 1024) (896 - (natToMod l + 1))))) (intToBits 0))
                                               (the (Bits 128) (intToBits (cast l)))))

parse512 : Bits (n * 512) -> Vect n (Bits 512)
parse512 = partition

parse1024 : Bits (n * 1024) -> Vect n (Bits 1024)
parse1024 = partition

-- Algorithms

data SecureHashAlgorithm1 : Type where
  SHA1 : Vect 5 (Bits 32) -> SecureHashAlgorithm1

vectIndex : (i : Nat) -> Vect (S n) a -> LTE i n -> a
vectIndex i v lte = index (natToFi i lte) v

sha1sched' : Vect 16 (Bits 32) -> Vect t (Bits 32) -> Bits 32
sha1sched' {t=t} M W =
  case isLTE t 15 of
    Yes lte => vectIndex t M lte
    No gt => rotateLeft 1 (foldl1 xor
                          --         (map (\off -> index (weakenN' (strMinus (natToFi t lteRefl) off)) W)
                          --              [3, 8, 14, 16]))
            [Vect.index (weakenN' (strMinus (natToFi t lteRefl)  3)) W,
             Vect.index (weakenN' (strMinus (natToFi t lteRefl)  8)) W,
             Vect.index (weakenN' (strMinus (natToFi t lteRefl) 14)) W,
             Vect.index (weakenN' (strMinus (natToFi t lteRefl) 16)) W])

-- NB: `foldl` doesn’t work here. Can we make something like `foldl`, but each
--      step is one element, and we get a Vect of elements back at the end?
sha1sched : Vect 16 (Bits 32) -> Vect 80 (Bits 32)
sha1sched mpart = foldl (\W, t => sha1sched' {t=t} mpart W) [] [0..79]

implementation Hash SecureHashAlgorithm1 512 160 where
  initialize _ = toList . parse512 . pad512 . Util.concat
  initialContext _ = SHA1 (map intToBits
                               [0x67452301,
                                0xefcdab89,
                                0x98badcfe,
                                0x10325476,
                                0xc3d2e1f0])
  updateContext (SHA1 v) block = SHA1 (zipWith plus (foldl for v [0..79]) v) where
    -- seems like we could do this in one pass
    W : Vect 80 (Bits 32)
    W = sha1sched (partition block)
    for : Vect 5 (Bits 32) -> Fin 80 -> Vect 5 (Bits 32)
    for [a, b, c, d, e] t =
      [Vect.foldl1 plus [rotateLeft 5 a, f t b c d, e, index t const1, index t W],
       a,
       rotateLeft 30 b,
       c,
       d]
  finalize (SHA1 v) = concat v

data SecureHashAlgorithm256 : Type where
  SHA256 : Vect 8 (Bits 32) -> SecureHashAlgorithm256

hash256 : Vect 8 (Bits 32) -> Bits 512 -> Vect 8 (Bits 32)

implementation Hash SecureHashAlgorithm256 512 256 where
  initialize _ = toList . parse512 . pad512 . Util.concat
  initialContext _ = SHA256 (map intToBits
                                 [0x6a09e667,
                                  0xbb67ae85,
                                  0x3c6ef372,
                                  0xa54ff53a,
                                  0x510e527f,
                                  0x9b05688c,
                                  0x1f83d9ab,
                                  0x5be0cd19])
  updateContext (SHA256 v) = SHA256 . hash256 v
  finalize (SHA256 v) = concat v

data SecureHashAlgorithm224 : Type where
  SHA224 : Vect 8 (Bits 32) -> SecureHashAlgorithm224

implementation Hash SecureHashAlgorithm224 512 224 where
  initialize _ = toList . parse512 . pad512 . Util.concat
  initialContext _ = SHA224 (map intToBits
                                 [0xc1059ed8,
                                  0x367cd507,
                                  0x3070dd17,
                                  0xf70e5939,
                                  0xffc00b31,
                                  0x68581511,
                                  0x64f98fa7,
                                  0xbefa4fa4])
  updateContext (SHA224 v) = SHA224 . hash256 v
  finalize (SHA224 v) = concat (take 7 v)

data SecureHashAlgorithm512 : Type where
  SHA512 : Vect 8 (Bits 64) -> SecureHashAlgorithm512

hash512 : Vect 8 (Bits 64) -> Bits 1024 -> Vect 8 (Bits 64)

implementation Hash SecureHashAlgorithm512 1024 512 where
  initialize _ = toList . parse1024 . pad1024 . Util.concat
  initialContext _ = SHA512 (map intToBits
                                 [0x6a09e667f3bcc908,
                                  0xbb67ae8584caa73b,
                                  0x3c6ef372fe94f82b,
                                  0xa54ff53a5f1d36f1,
                                  0x510e527fade682d1,
                                  0x9b05688c2b3e6c1f,
                                  0x1f83d9abfb41bd6b,
                                  0x5be0cd19137e2179])
  updateContext (SHA512 v) = SHA512 . hash512 v
  finalize (SHA512 v) = concat v

data SecureHashAlgorithm512_224 : Type where
  SHA512_224 : Vect 8 (Bits 64) -> SecureHashAlgorithm512_224

implementation Hash SecureHashAlgorithm512_224 1024 224 where
  initialize _ = toList . parse1024 . pad1024 . Util.concat
  initialContext _ = SHA512_224 (map intToBits
                                     [0x8C3D37C819544DA2,
                                      0x73E1996689DCD4D6,
                                      0x1DFAB7AE32FF9C82,
                                      0x679DD514582F9FCF,
                                      0x0F6D2B697BD44DA8,
                                      0x77E36F7304C48942,
                                      0x3F9D85A86A1D36C8,
                                      0x1112E6AD91D692A1])
  updateContext (SHA512_224 v) = SHA512_224 . hash512 v
  finalize (SHA512_224 v) = truncate (concat (take 4 v))

data SecureHashAlgorithm512_256 : Type where
  SHA512_256 : Vect 8 (Bits 64) -> SecureHashAlgorithm512_256

implementation Hash SecureHashAlgorithm512_256 1024 256 where
  initialize _ = toList . parse1024 . pad1024 . Util.concat
  initialContext _ = SHA512_256 (map intToBits
                                     [0x22312194FC2BF72C,
                                      0x9F555FA3C84C64C2,
                                      0x2393B86B6F53B151,
                                      0x963877195940EABD,
                                      0x96283EE2A88EFFE3,
                                      0xBE5E1E2553863992,
                                      0x2B0199FC2C85B8AA,
                                      0x0EB72DDC81C52CA2])
  updateContext (SHA512_256 v) = SHA512_256 . hash512 v
  finalize (SHA512_256 v) = concat (take 4 v)

data SecureHashAlgorithm384 : Type where
  SHA384 : Vect 8 (Bits 64) -> SecureHashAlgorithm384

implementation Hash SecureHashAlgorithm384 1024 384 where
  initialize _ = toList . parse1024 . pad1024 . Util.concat
  initialContext _ = SHA384 (map intToBits
                                 [0xcbbb9d5dc1059ed8,
                                  0x629a292a367cd507,
                                  0x9159015a3070dd17,
                                  0x152fecd8f70e5939,
                                  0x67332667ffc00b31,
                                  0x8eb44a8768581511,
                                  0xdb0c2e0d64f98fa7,
                                  0x47b5481dbefa4fa4])
  updateContext (SHA384 v) = SHA384 . hash512 v
  finalize (SHA384 v) = concat (take 6 v)


import Data.Either
import Data.List
import Data.Maybe
import Data.String
import Data.Binary
import Data.Binary.Digit

import System.File

Eq Digit where
  I == I = True
  O == O = True
  I == O = False
  O == I = False

lookupMaybe : Nat -> List a -> Maybe a
lookupMaybe _ [] = Nothing
lookupMaybe Z (x :: _) = Just x
lookupMaybe (S n) (_ :: l) = lookupMaybe n l

significant : (Nat, Nat) -> Bin -> (Nat, Nat)
significant (n, c) b = case lookupMaybe n b of
                            Just d => case d of
                                           I => (n, c + 1)
                                           O => (n, c)
                            Nothing => (n, c)

toBin : String -> Bin
toBin s = (\c => if c == '1' then I else O) <$> unpack s

oxygen2 : Nat -> List Bin -> Bin
oxygen2 n [] = []
oxygen2 n (b :: []) = b
oxygen2 n l@(_ :: _ :: _) = let len = length l
                                (_, c) = foldl significant (n, 0) l
                                d = if c + c >= len then I else O in
                                oxygen2 (n + 1) $ filter (\b => case lookupMaybe n b of
                                                                     Just d2 => d == d2
                                                                     Nothing => False) $ l

oxygen : List Bin -> Bin
oxygen l = oxygen2 0 l

scrubber2 : Nat -> List Bin -> Bin
scrubber2 n [] = []
scrubber2 n (b :: []) = b
scrubber2 n l@(_ :: _ :: _) = let len = length l
                                  (_, c) = foldl significant (n, 0) l
                                  d = if c + c >= len then O else I in
                                  scrubber2 (n + 1) $ filter (\b => case lookupMaybe n b of
                                                                         Just d2 => d == d2
                                                                         Nothing => False) $ l

scrubber : List Bin -> Bin
scrubber l = scrubber2 0 l

run : String -> IO ()
run s = do let lines = toBin <$> (lines $ trim $ s)
           let o = toNat $ reverse $ oxygen $ lines
           let s = toNat $ reverse $ scrubber $ lines
           putStrLn $ show $ s * o

main : IO ()
main = do Right s <- readFile "input.txt"
            | Left err => putStrLn $ show err
          run s


||| Example Queries over AList implemented graphs.
|||
||| TODO make query higher-order.
module Data.Graph.AList.Query

import Effects
import Effect.State
import Effect.StdIO

import Data.Graph.AList

import Data.Queue
import Data.Stack

%access public

-- --------------------------------------------------------------------- [ BFS ]
||| The effects used in a BFS.
BfsEffs : List EFFECT
BfsEffs = [ 'next ::: STATE (Queue Node),
            'seen ::: STATE (List Node),
            STDIO]

||| Traverse the given graph using a BFS, printing the visited nodes
||| in order of visit.
private
doTraceBFS : (Ord n, Show n) => Graph n e -> Eff () BfsEffs
doTraceBFS g = do
   q <- 'next :- get
   case popQ q of
     Nothing         => pure () -- Stop if all nodes have been traversed.
     Just (curr, q') => do
       'next :- put q'
       -- Do the thing we do at the nodes.
       putStrLn $ show curr

       -- Move on
       let es = getSuccs curr g
       doMoves es

       -- Repeat
       doTraceBFS g
  where
    doMove : Node -> Eff () BfsEffs
    doMove n = do
      visited <- 'seen :- get
      case elem n visited of
        True => pure ()
        False => do
          'seen :- update (\xs => [n] ++ xs)
          'next :- update (\xs => pushQ n xs)

    doMoves : Maybe (List Node) -> Eff () BfsEffs
    doMoves Nothing = pure ()
    doMoves (Just Nil) = pure ()
    doMoves (Just (e::es)) = do
       doMove e
       doMoves (Just es)

||| Traverse the given graph using a BFS, printing the visited nodes
||| in order of visit.
traceBfsIO : (Ord v, Show v) => Node -> Graph v e -> IO ()
traceBfsIO n g = runInit ['next := initQ n, 'seen := List.Nil, ()] $ doTraceBFS g

-- --------------------------------------------------------------------- [ DFS ]
||| The Effects used in a DFS.
DfsEffs : List EFFECT
DfsEffs = [ 'next ::: STATE (Stack Node),
            'seen ::: STATE (List Node),
            STDIO]

||| Traverse the given graph using a DFS, printing the visited nodes
||| in order of visit.
doTraceDFS : (Ord n, Show n) => Graph n e -> Eff () DfsEffs
doTraceDFS g = do
    s <- 'next :- get
    case popS s of
      Nothing         => pure ()
      Just (curr, s') => do
        'next :- put s'
        visited <- 'seen :- get
        case elem curr visited of
          True  => pure ()
          False => do
            putStrLn $ show curr
            let es = getSuccs curr g
            'seen :- update (\xs => [curr] ++ xs)
            'next :- update (\xs => pushSThings (fromMaybe Nil es) s)
            doTraceDFS g

||| Traverse the given graph using a DFS, printing the visited nodes
||| in order of visit.
traceDfsIO : (Ord v, Show v) => Node -> Graph v e -> IO ()
traceDfsIO n g = runInit ['next := initS n, 'seen := List.Nil, ()] $ doTraceDFS g
-- --------------------------------------------------------------------- [ EOF ]


> module NonNegRational.open_issues.Main

> import NonNegRational.NonNegRational
> import NonNegRational.BasicOperations
> import NonNegRational.BasicProperties
> import Fraction.Fraction
> import PNat.PNat
> import Nat.Positive

> %default total
> %auto_implicits off

> n : Nat
> n = 1

> x : NonNegRational
> x = fromFraction (1, Element (S n) MkPositive)

> y : NonNegRational
> y = fromFraction (n, Element (S n) MkPositive)

> q : x + y = 1
> q = Refl

> main : IO ()
> main = do putStrLn ("x           = " ++ show x)
>           putStrLn ("y           = " ++ show y)
>           putStrLn ("x + y       = " ++ show (x + y))

For small |n|, type checking time is roughly constant in |n| and
execution time is roughly linear in |n| as one would expect. But:

1) For |n > 399| the computation segfaults

2) Uncommenting lines 22-23 (the computation of |q|) yields unacceptable
   type checking times even for very small |n|:

     n = 1  ->   16 sec.
     n = 2  ->   18 sec.
     n = 3  ->   20 sec.
     n = 4  ->   28 sec.
     n = 5  ->   47 sec.
     n = 6  ->   88 sec.
     n = 7  ->  188 sec.
     n = 8  ->  647 sec.
     n = 9  ->  killed


module Control.Applicative.Indexed

import Control.Functor.Indexed

infixl 3 <<*>>, <<*, *>>

public export
interface IndexedFunctor z z f => IndexedApplicative z f | f where
  total
  pure : {0 i : z} -> (x : a) -> f a i i

  total
  ap : {0 i,j,k : z} -> f (a -> b) i j -> f a j k -> f b i k

public export
(<<*>>) : IndexedApplicative z f => f (a -> b) i j -> f a j k -> f b i k
(<<*>>) = ap

public export
(<<*) : IndexedApplicative z f => f a i j -> f b j k -> f a i k
x <<* y = map const x <<*>> y

public export
(*>>) : IndexedApplicative z f => f a i j -> f b j k -> f b i k
x *>> y = map (const id) x <<*>> y

||| Conditionally execute an applicative expression when the boolean is true.
public export
when : IndexedApplicative z f => Bool -> Lazy (f () i i) -> f () i i
when True y  = y
when False y = pure ()

||| Execute an applicative expression unless the boolean is true.
%inline
public export
unless : IndexedApplicative z f => Bool -> Lazy (f () i i) -> f () i i
unless = when . not

||| Map each element of a structure to a computation, evaluate those
||| computations and discard the results.
public export
traverse_ : (Foldable t, IndexedApplicative z f) => (a -> f b i i) -> t a -> f () i i
traverse_ f = foldr ((*>>) . f) (pure ())

||| Evaluate each computation in a structure and discard the results.
public export
sequence_ : (Foldable t, IndexedApplicative z f) => t (f a i i) -> f () i i
sequence_ = foldr (*>>) (pure ())

||| Like `traverse_` but with the arguments flipped.
public export
for_ : (Foldable t, IndexedApplicative z f) => t a -> (a -> f b i i) -> f () i i
for_ = flip traverse_


module Main

import Data.Vect
import System.REPL
import Data.String

infixr 5 .+.

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

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

record DataStore where
  constructor MkData
  schema : Schema
  size : Nat
  items : Vect size (SchemaType schema)

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

-- addToStore : DataStore -> String -> DataStore
-- addToStore (MkData _ 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 : String -> 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 = let (cmd, args) = span (/= ' ') input in
--                   parseCommand cmd (ltrim args)

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

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

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

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


module Main

import System

countdown : (secs : Nat) -> IO ()
countdown Z = putStrLn "Kaboom"
countdown secs@(S k) = do putStrLn $ show secs
                          usleep 1000000
                          countdown k


module Main

import Effects
import Effect.State

data BTree a = Leaf
             | Node (BTree a) a (BTree a)

Show a => Show (BTree a) where
    show Leaf = "[]"
    show (Node l x r) = "[" ++ show l ++ " "
                            ++ show x ++ " "
                            ++ show r ++ "]"

testTree : BTree String
testTree = Node (Node Leaf "Jim" Leaf)
                "Fred"
                (Node (Node Leaf "Alice" Leaf)
                      "Sheila"
                      (Node Leaf "Bob" Leaf))

-- treeTag : (i : Int) -> BTree a -> BTree (Int, a)

-- treeTagAux : (i : Int) -> BTree a -> (Int, BTree (Int, a))
-- treeTagAux i Leaf = (i, Leaf)
-- treeTagAux i (Node l x r)
--        = let (i', l') = treeTagAux i l in
--          let x' = (i', x) in
--          let (i'', r') = treeTagAux (i' + 1) r in
--              (i'', Node l' x' r')

treeTagAux : BTree a -> Eff (BTree (Int, a)) [STATE Int]
treeTagAux Leaf = pure Leaf
treeTagAux (Node l x r)
    = do l' <- treeTagAux l
         i <- get
         put (i + 1)
         r' <- treeTagAux r
         pure (Node l' (i, x) r')

-- treeTag : (i : Int) -> BTree a -> BTree (Int, a)
-- treeTag i x = snd (treeTagAux i x)

treeTag : (i : Int) -> BTree a -> BTree (Int, a)
treeTag i x = runPure (do put i
                          treeTagAux x)

main : IO ()
main = print (treeTag 1 testTree)


--
-- Primitive casts: Specification
--
-- a. Unsigned integers
--
--    Unsigned integers with a precision of x bit have a valid
--    range of [0,2^x - 1]. When casting from another integral type of value y,
--    the value is checked for being in bounds, and if it is not, the
--    unsigned remainder modulo 2^x of y is returned.
--
--    When casting from a `Double`, the value is first truncated towards 0,
--    before applying the inbounds check and (if necessary) calculating
--    the unsigned remainder modulo 2^x.
--
--    When casting from a `String`, the value is first converted to a floating
--    point number by the backend and then truncated as described above.
--
--    Example: For `Bits8` the valid range is [0,255]. Below are some
--             example casts.
--
--               cast {from = Integer} {to = Bits8} 12   = 12
--               cast {from = Integer} {to = Bits8} 256  = 0
--               cast {from = Integer} {to = Bits8} 259  = 3
--               cast {from = Integer} {to = Bits8} (-2) = 254
--               cast {from = Double} {to = Bits8} (-12.001) = 244
--               cast {from = Double} {to = Bits8} ("-12.001") = 244
--
-- b. Signed integers
--
--    Signed integers with a precision of x bit have a valid
--    range of [-2^(x-1),2^(x-1) - 1]. When casting from another
--    integral type of value y, the unsigned remainder module 2^x
--    is calculated. If the result is >= 2^(x-1), 2^x is subtracted
--    from the result. This is the same behavior as for instance in Haskell.
--
--    When casting from a `Double`, the value is first truncated towards 0,
--    before applying the inbounds check and (if necessary) truncating
--    the value.
--
--    When casting from a `String`, the value is first converted to a floating
--    point number by the backend and then truncated as described above.
--
--    Example: For `Int8` the valid range is [-128,127]. Below are some
--             example casts.
--
--               cast {from = Integer} {to = Int8} 12   = 12
--               cast {from = Integer} {to = Int8} 256  = 0
--               cast {from = Integer} {to = Int8} 259  = 4
--               cast {from = Integer} {to = Int8} (-128) = (-128)
--               cast {from = Integer} {to = Int8} (-129) = 127
--               cast {from = Double}  {to = Int8} (-12.001) = (-12)
--               cast {from = Double}  {to = Int8} ("-12.001") = (-12)
--
-- c. Characters
--
--    Casts from all integral types to `Char` are supported. Note however,
--    that only casts in the non-surrogate range are supported, that is
--    values in the ranges [0,0xd7ff] and [0xe000,0x10ffff], or, in decimal
--    notation, [0,55295] and [57344,1114111].
--
--    All casts from integer types to `Char` are therefore submitted to a
--    bounds check, and, in case the value is out of bounds, are converted to `'\0'`.
--
--
-- Test all casts from and to integral types.
-- The `Cast` implementations in here should go to `Prelude`, once
-- a new minor version of the compiler is released.
--
-- These tests verify also that the full range of integer literals
-- is supported for every integral type.
--
-- Nothing fancy is being done here:
-- All test cases have been hand-written.

import Data.List

--------------------------------------------------------------------------------
--          Int8
--------------------------------------------------------------------------------

Show Int8 where
  show = prim__cast_Int8String

public export
Eq Int8 where
  x == y = intToBool (prim__eq_Int8 x y)

Num Int8 where
  (+) = prim__add_Int8
  (*) = prim__mul_Int8
  fromInteger = prim__cast_IntegerInt8

Neg Int8 where
  (-)    = prim__sub_Int8
  negate = prim__sub_Int8 0

Cast Int8 Bits8 where
  cast = prim__cast_Int8Bits8

Cast Int8 Bits16 where
  cast = prim__cast_Int8Bits16

Cast Int8 Bits32 where
  cast = prim__cast_Int8Bits32

Cast Int8 Bits64 where
  cast = prim__cast_Int8Bits64

Cast Int8 Int16 where
  cast = prim__cast_Int8Int16

Cast Int8 Int32 where
  cast = prim__cast_Int8Int32

Cast Int8 Int64 where
  cast = prim__cast_Int8Int64

Cast Int8 Int where
  cast = prim__cast_Int8Int

Cast Int8 Integer where
  cast = prim__cast_Int8Integer

Cast Int8 String where
  cast = prim__cast_Int8String

Cast Int8 Char where
  cast = prim__cast_Int8Char

Cast Int8 Double where
  cast = prim__cast_Int8Double

--------------------------------------------------------------------------------
--          Int16
--------------------------------------------------------------------------------

public export
Eq Int16 where
  x == y = intToBool (prim__eq_Int16 x y)

Show Int16 where
  show = prim__cast_Int16String

Num Int16 where
  (+) = prim__add_Int16
  (*) = prim__mul_Int16
  fromInteger = prim__cast_IntegerInt16

Neg Int16 where
  (-)    = prim__sub_Int16
  negate = prim__sub_Int16 0

Cast Int16 Bits8 where
  cast = prim__cast_Int16Bits8

Cast Int16 Bits16 where
  cast = prim__cast_Int16Bits16

Cast Int16 Bits32 where
  cast = prim__cast_Int16Bits32

Cast Int16 Bits64 where
  cast = prim__cast_Int16Bits64

Cast Int16 Int8 where
  cast = prim__cast_Int16Int8

Cast Int16 Int32 where
  cast = prim__cast_Int16Int32

Cast Int16 Int64 where
  cast = prim__cast_Int16Int64

Cast Int16 Int where
  cast = prim__cast_Int16Int

Cast Int16 Integer where
  cast = prim__cast_Int16Integer

Cast Int16 String where
  cast = prim__cast_Int16String

Cast Int16 Char where
  cast = prim__cast_Int16Char

Cast Int16 Double where
  cast = prim__cast_Int16Double

--------------------------------------------------------------------------------
--          Int32
--------------------------------------------------------------------------------

Show Int32 where
  show = prim__cast_Int32String

public export
Eq Int32 where
  x == y = intToBool (prim__eq_Int32 x y)

Num Int32 where
  (+) = prim__add_Int32
  (*) = prim__mul_Int32
  fromInteger = prim__cast_IntegerInt32

Neg Int32 where
  (-)    = prim__sub_Int32
  negate = prim__sub_Int32 0

Cast Int32 Bits8 where
  cast = prim__cast_Int32Bits8

Cast Int32 Bits16 where
  cast = prim__cast_Int32Bits16

Cast Int32 Bits32 where
  cast = prim__cast_Int32Bits32

Cast Int32 Bits64 where
  cast = prim__cast_Int32Bits64

Cast Int32 Int8 where
  cast = prim__cast_Int32Int8

Cast Int32 Int16 where
  cast = prim__cast_Int32Int16

Cast Int32 Int64 where
  cast = prim__cast_Int32Int64

Cast Int32 Int where
  cast = prim__cast_Int32Int

Cast Int32 Integer where
  cast = prim__cast_Int32Integer

Cast Int32 String where
  cast = prim__cast_Int32String

Cast Int32 Char where
  cast = prim__cast_Int32Char

Cast Int32 Double where
  cast = prim__cast_Int32Double

--------------------------------------------------------------------------------
--          Int64
--------------------------------------------------------------------------------

Show Int64 where
  show = prim__cast_Int64String

public export
Eq Int64 where
  x == y = intToBool (prim__eq_Int64 x y)

Num Int64 where
  (+) = prim__add_Int64
  (*) = prim__mul_Int64
  fromInteger = prim__cast_IntegerInt64

Neg Int64 where
  (-)    = prim__sub_Int64
  negate = prim__sub_Int64 0

Cast Int64 Bits8 where
  cast = prim__cast_Int64Bits8

Cast Int64 Bits16 where
  cast = prim__cast_Int64Bits16

Cast Int64 Bits32 where
  cast = prim__cast_Int64Bits32

Cast Int64 Bits64 where
  cast = prim__cast_Int64Bits64

Cast Int64 Int8 where
  cast = prim__cast_Int64Int8

Cast Int64 Int16 where
  cast = prim__cast_Int64Int16

Cast Int64 Int32 where
  cast = prim__cast_Int64Int32

Cast Int64 Int where
  cast = prim__cast_Int64Int

Cast Int64 Integer where
  cast = prim__cast_Int64Integer

Cast Int64 String where
  cast = prim__cast_Int64String

Cast Int64 Char where
  cast = prim__cast_Int64Char

Cast Int64 Double where
  cast = prim__cast_Int64Double

--------------------------------------------------------------------------------
--          Int
--------------------------------------------------------------------------------

Cast Int Int8 where
  cast = prim__cast_IntInt8

Cast Int Int16 where
  cast = prim__cast_IntInt16

Cast Int Int32 where
  cast = prim__cast_IntInt32

Cast Int Int64 where
  cast = prim__cast_IntInt64

--------------------------------------------------------------------------------
--          Integer
--------------------------------------------------------------------------------

Cast Integer Int8 where
  cast = prim__cast_IntegerInt8

Cast Integer Int16 where
  cast = prim__cast_IntegerInt16

Cast Integer Int32 where
  cast = prim__cast_IntegerInt32

Cast Integer Int64 where
  cast = prim__cast_IntegerInt64

Cast Integer Char where
  cast = prim__cast_IntegerChar

--------------------------------------------------------------------------------
--          Bits8
--------------------------------------------------------------------------------

Cast Bits8 Int8 where
  cast = prim__cast_Bits8Int8

Cast Bits8 Int16 where
  cast = prim__cast_Bits8Int16

Cast Bits8 Int32 where
  cast = prim__cast_Bits8Int32

Cast Bits8 Int64 where
  cast = prim__cast_Bits8Int64

Cast Bits8 String where
  cast = prim__cast_Bits8String

Cast Bits8 Char where
  cast = prim__cast_Bits8Char

Cast Bits8 Double where
  cast = prim__cast_Bits8Double

--------------------------------------------------------------------------------
--          Bits16
--------------------------------------------------------------------------------

Cast Bits16 Int8 where
  cast = prim__cast_Bits16Int8

Cast Bits16 Int16 where
  cast = prim__cast_Bits16Int16

Cast Bits16 Int32 where
  cast = prim__cast_Bits16Int32

Cast Bits16 Int64 where
  cast = prim__cast_Bits16Int64

Cast Bits16 String where
  cast = prim__cast_Bits16String

Cast Bits16 Char where
  cast = prim__cast_Bits16Char

Cast Bits16 Double where
  cast = prim__cast_Bits16Double

--------------------------------------------------------------------------------
--          Bits32
--------------------------------------------------------------------------------

Cast Bits32 Int8 where
  cast = prim__cast_Bits32Int8

Cast Bits32 Int16 where
  cast = prim__cast_Bits32Int16

Cast Bits32 Int32 where
  cast = prim__cast_Bits32Int32

Cast Bits32 Int64 where
  cast = prim__cast_Bits32Int64

Cast Bits32 String where
  cast = prim__cast_Bits32String

Cast Bits32 Char where
  cast = prim__cast_Bits32Char

Cast Bits32 Double where
  cast = prim__cast_Bits32Double

--------------------------------------------------------------------------------
--          Bits64
--------------------------------------------------------------------------------

Cast Bits64 Int8 where
  cast = prim__cast_Bits64Int8

Cast Bits64 Int16 where
  cast = prim__cast_Bits64Int16

Cast Bits64 Int32 where
  cast = prim__cast_Bits64Int32

Cast Bits64 Int64 where
  cast = prim__cast_Bits64Int64

Cast Bits64 String where
  cast = prim__cast_Bits64String

Cast Bits64 Char where
  cast = prim__cast_Bits64Char

Cast Bits64 Double where
  cast = prim__cast_Bits64Double

--------------------------------------------------------------------------------
--          String
--------------------------------------------------------------------------------

Cast String Bits8 where
  cast = prim__cast_StringBits8

Cast String Bits16 where
  cast = prim__cast_StringBits16

Cast String Bits32 where
  cast = prim__cast_StringBits32

Cast String Bits64 where
  cast = prim__cast_StringBits64

Cast String Int8 where
  cast = prim__cast_StringInt8

Cast String Int16 where
  cast = prim__cast_StringInt16

Cast String Int32 where
  cast = prim__cast_StringInt32

Cast String Int64 where
  cast = prim__cast_StringInt64

--------------------------------------------------------------------------------
--          Double
--------------------------------------------------------------------------------

Cast Double Bits8 where
  cast = prim__cast_DoubleBits8

Cast Double Bits16 where
  cast = prim__cast_DoubleBits16

Cast Double Bits32 where
  cast = prim__cast_DoubleBits32

Cast Double Bits64 where
  cast = prim__cast_DoubleBits64

Cast Double Int8 where
  cast = prim__cast_DoubleInt8

Cast Double Int16 where
  cast = prim__cast_DoubleInt16

Cast Double Int32 where
  cast = prim__cast_DoubleInt32

Cast Double Int64 where
  cast = prim__cast_DoubleInt64

--------------------------------------------------------------------------------
--          Tests
--------------------------------------------------------------------------------

showTpe : Type -> String
showTpe Bits16  = "Bits16"
showTpe Bits32  = "Bits32"
showTpe Bits64  = "Bits64"
showTpe Bits8   = "Bits8"
showTpe Char    = "Char"
showTpe Double  = "Double"
showTpe Int     = "Int"
showTpe Int16   = "Int16"
showTpe Int32   = "Int32"
showTpe Int64   = "Int64"
showTpe Int8    = "Int8"
showTpe Integer = "Integer"
showTpe String  = "String"
showTpe _       = "unknown type"

testCasts : (a: Type) -> (b : Type) -> (Cast a b, Show a, Show b, Eq b) =>
            List (a,b) -> List String
testCasts a b = mapMaybe doTest
  where doTest : (a,b) -> Maybe String
        doTest (x,y) =
          let y2 = cast {to = b} x
           in if y == y2 then Nothing
              else Just $  #"Invalid cast from \#{showTpe a} to \#{showTpe b}: "#
                        ++ #"expected \#{show y} but got \#{show y2} when casting from \#{show x}"#

maxBits8 : Bits8
maxBits8 = 0xff

maxBits16 : Bits16
maxBits16 = 0xffff

maxBits32 : Bits32
maxBits32 = 0xffffffff

maxBits64 : Bits64
maxBits64 = 0xffffffffffffffff

results : List String
results =  testCasts Int8 Int16   [(-129,127),(-128,-128),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Int32   [(-129,127),(-128,-128),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Int64   [(-129,127),(-128,-128),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Int     [(-129,127),(-128,-128),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Double  [(-129,127),(-128,-128),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 String  [(-129,"127"),(-128,"-128"),(0,"0"),(127,"127"),(128,"-128")]
        ++ testCasts Int8 Integer [(-129,127),(-128,-128),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Bits8   [(-129,127),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Bits16  [(-129,127),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Bits32  [(-129,127),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Bits64  [(-129,127),(0,0),(127,127),(128,-128)]

        ++ testCasts Int16 Int8    [(-32769,32767),(-32768,0),(0,0),(32767,-1),(32768,0)]
        ++ testCasts Int16 Int32   [(-32769,32767),(-32768,-32768),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Int64   [(-32769,32767),(-32768,-32768),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Int     [(-32769,32767),(-32768,-32768),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Double  [(-32769,32767),(-32768,-32768),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 String  [(-32769,"32767"),(-32768,"-32768"),(0,"0"),(32767,"32767"),(32768,"-32768")]
        ++ testCasts Int16 Integer [(-32769,32767),(-32768,-32768),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Bits8   [(-32769,32767),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Bits16  [(-32769,32767),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Bits32  [(-32769,32767),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Bits64  [(-32769,32767),(0,0),(32767,32767),(32768,-32768)]

        ++ testCasts Int32 Int8    [(-2147483649,2147483647),(-2147483648,0),(0,0),(2147483647,-1),(2147483648,0)]
        ++ testCasts Int32 Int16   [(-2147483649,2147483647),(-2147483648,0),(0,0),(2147483647,-1),(2147483648,0)]
        ++ testCasts Int32 Int64   [(-2147483649,2147483647),(-2147483648,-2147483648),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 Int     [(-2147483649,2147483647),(-2147483648,-2147483648),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 Double  [(-2147483649,2147483647),(-2147483648,-2147483648),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 String  [(-2147483649,"2147483647"),(-2147483648,"-2147483648"),(0,"0"),(2147483647,"2147483647"),(2147483648,"-2147483648")]
        ++ testCasts Int32 Integer [(-2147483649,2147483647),(-2147483648,-2147483648),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 Bits8   [(-2147483649,2147483647),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 Bits16  [(-2147483649,2147483647),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 Bits32  [(-2147483649,2147483647),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 Bits64  [(-2147483649,2147483647),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]

        ++ testCasts Int64 Int8    [(-9223372036854775809,9223372036854775807),(-9223372036854775808,0),(0,0),(9223372036854775807,-1),(9223372036854775808,0)]
        ++ testCasts Int64 Int16   [(-9223372036854775809,9223372036854775807),(-9223372036854775808,0),(0,0),(9223372036854775807,-1),(9223372036854775808,0)]
        ++ testCasts Int64 Int32   [(-9223372036854775809,9223372036854775807),(-9223372036854775808,0),(0,0),(9223372036854775807,-1),(9223372036854775808,0)]
        ++ testCasts Int64 Int     [(-9223372036854775809,9223372036854775807),(-9223372036854775808,-9223372036854775808),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]
        ++ testCasts Int64 Double  [(-9223372036854775809,9223372036854775807),(-9223372036854775808,-9223372036854775808),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]
        ++ testCasts Int64 String  [(-9223372036854775809,"9223372036854775807"),(-9223372036854775808,"-9223372036854775808"),(0,"0"),(9223372036854775807,"9223372036854775807"),(9223372036854775808,"-9223372036854775808")]
        ++ testCasts Int64 Integer [(-9223372036854775809,9223372036854775807),(-9223372036854775808,-9223372036854775808),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]
        ++ testCasts Int64 Bits8   [(-9223372036854775809,255),(0,0),(9223372036854775807,0xff),(9223372036854775808,0)]
        ++ testCasts Int64 Bits16  [(-9223372036854775809,65535),(0,0),(9223372036854775807,0xffff),(9223372036854775808,0)]
        ++ testCasts Int64 Bits32  [(-9223372036854775809,4294967295),(0,0),(9223372036854775807,0xffffffff),(9223372036854775808,0)]
        ++ testCasts Int64 Bits64  [(-9223372036854775809,9223372036854775807),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]

        ++ testCasts Int Int8    [(-9223372036854775809,9223372036854775807),(-9223372036854775808,0),(0,0),(9223372036854775807,-1),(9223372036854775808,0)]
        ++ testCasts Int Int16   [(-9223372036854775809,9223372036854775807),(-9223372036854775808,0),(0,0),(9223372036854775807,-1),(9223372036854775808,0)]
        ++ testCasts Int Int32   [(-9223372036854775809,9223372036854775807),(-9223372036854775808,0),(0,0),(9223372036854775807,-1),(9223372036854775808,0)]
        ++ testCasts Int Int64   [(-9223372036854775809,9223372036854775807),(-9223372036854775808,-9223372036854775808),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]
        ++ testCasts Int Double  [(-9223372036854775809,9223372036854775807),(-9223372036854775808,-9223372036854775808),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]
        ++ testCasts Int String  [(-9223372036854775809,"9223372036854775807"),(-9223372036854775808,"-9223372036854775808"),(0,"0"),(9223372036854775807,"9223372036854775807"),(9223372036854775808,"-9223372036854775808")]
        ++ testCasts Int Integer [(-9223372036854775809,9223372036854775807),(-9223372036854775808,-9223372036854775808),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]
        ++ testCasts Int Bits8   [(-9223372036854775809,255),(0,0),(9223372036854775807,0xff),(9223372036854775808,0)]
        ++ testCasts Int Bits16  [(-9223372036854775809,65535),(0,0),(9223372036854775807,0xffff),(9223372036854775808,0)]
        ++ testCasts Int Bits32  [(-9223372036854775809,4294967295),(0,0),(9223372036854775807,0xffffffff),(9223372036854775808,0)]
        ++ testCasts Int Bits64  [(-9223372036854775809,9223372036854775807),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]

        ++ testCasts Integer Int8    [(-170141183460469231731687303715884105729,-1),(-170141183460469231731687303715884105728,0),(0,0),(170141183460469231731687303715884105727,-1),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Int16   [(-170141183460469231731687303715884105729,-1),(-170141183460469231731687303715884105728,0),(0,0),(170141183460469231731687303715884105727,-1),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Int32   [(-170141183460469231731687303715884105729,-1),(-170141183460469231731687303715884105728,0),(0,0),(170141183460469231731687303715884105727,-1),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Int64   [(-170141183460469231731687303715884105729,-1),(-170141183460469231731687303715884105728,0),(0,0),(170141183460469231731687303715884105727,-1),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Int     [(-170141183460469231731687303715884105729,-1),(-170141183460469231731687303715884105728,0),(0,0),(170141183460469231731687303715884105727,-1),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer String  [(-170141183460469231731687303715884105729,"-170141183460469231731687303715884105729"),(-170141183460469231731687303715884105728,"-170141183460469231731687303715884105728"),(0,"0"),(170141183460469231731687303715884105727,"170141183460469231731687303715884105727"),(170141183460469231731687303715884105728,"170141183460469231731687303715884105728")]
        ++ testCasts Integer Bits8   [(-170141183460469231731687303715884105729,maxBits8),(0,0),(170141183460469231731687303715884105727,0xff),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Bits16  [(-170141183460469231731687303715884105729,maxBits16),(0,0),(170141183460469231731687303715884105727,0xffff),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Bits32  [(-170141183460469231731687303715884105729,maxBits32),(0,0),(170141183460469231731687303715884105727,0xffffffff),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Bits64  [(-170141183460469231731687303715884105729,maxBits64),(0,0),(170141183460469231731687303715884105727,0xffffffffffffffff),(170141183460469231731687303715884105728,0)]

        ++ testCasts Bits8 Int8    [(0,0),(255,-1),(256,0)]
        ++ testCasts Bits8 Int16   [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Int32   [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Int64   [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Int     [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Double  [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 String  [(0,"0"),(255,"255"),(256,"0")]
        ++ testCasts Bits8 Integer [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Bits16  [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Bits32  [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Bits64  [(0,0),(255,255),(256,0)]

        ++ testCasts Bits16 Int8    [(0,0),(0xffff,-1),(0x10000,0)]
        ++ testCasts Bits16 Int16   [(0,0),(0xffff,-1),(0x10000,0)]
        ++ testCasts Bits16 Int32   [(0,0),(0xffff,0xffff),(0x10000,0)]
        ++ testCasts Bits16 Int64   [(0,0),(0xffff,0xffff),(0x10000,0)]
        ++ testCasts Bits16 Int     [(0,0),(0xffff,0xffff),(0x10000,0)]
        ++ testCasts Bits16 Double  [(0,0),(0xffff,0xffff),(0x10000,0)]
        ++ testCasts Bits16 String  [(0,"0"),(0xffff,"65535"),(0x10000,"0")]
        ++ testCasts Bits16 Integer [(0,0),(0xffff,0xffff),(0x10000,0)]
        ++ testCasts Bits16 Bits8   [(0,0),(0xffff,0xff),(0x10000,0)]
        ++ testCasts Bits16 Bits32  [(0,0),(0xffff,0xffff),(0x10000,0)]
        ++ testCasts Bits16 Bits64  [(0,0),(0xffff,0xffff),(0x10000,0)]

        ++ testCasts Bits32 Int8    [(0,0),(0xffffffff,-1),(0x100000000,0)]
        ++ testCasts Bits32 Int16   [(0,0),(0xffffffff,-1),(0x100000000,0)]
        ++ testCasts Bits32 Int32   [(0,0),(0xffffffff,-1),(0x100000000,0)]
        ++ testCasts Bits32 Int64   [(0,0),(0xffffffff,0xffffffff),(0x100000000,0)]
        ++ testCasts Bits32 Int     [(0,0),(0xffffffff,0xffffffff),(0x100000000,0)]
        ++ testCasts Bits32 Double  [(0,0),(0xffffffff,0xffffffff),(0x100000000,0)]
        ++ testCasts Bits32 String  [(0,"0"),(0xffffffff,"4294967295"),(0x100000000,"0")]
        ++ testCasts Bits32 Integer [(0,0),(0xffffffff,0xffffffff),(0x100000000,0)]
        ++ testCasts Bits32 Bits8   [(0,0),(0xffffffff,0xff),(0x100000000,0)]
        ++ testCasts Bits32 Bits16  [(0,0),(0xffffffff,0xffff),(0x100000000,0)]
        ++ testCasts Bits32 Bits64  [(0,0),(0xffffffff,0xffffffff),(0x100000000,0)]

        ++ testCasts Bits64 Int8    [(0,0),(0xffffffffffffffff,-1),(0x10000000000000000,0)]
        ++ testCasts Bits64 Int16   [(0,0),(0xffffffffffffffff,-1),(0x10000000000000000,0)]
        ++ testCasts Bits64 Int32   [(0,0),(0xffffffffffffffff,-1),(0x10000000000000000,0)]
        ++ testCasts Bits64 Int64   [(0,0),(0xffffffffffffffff,-1),(0x10000000000000000,0)]
        ++ testCasts Bits64 Int     [(0,0),(0xffffffffffffffff,-1),(0x10000000000000000,0)]
        ++ testCasts Bits64 Double  [(0,0),(0xffffffffffffffff,0xffffffffffffffff),(0x10000000000000000,0)]
        ++ testCasts Bits64 String  [(0,"0"),(0xffffffffffffffff,"18446744073709551615"),(0x10000000000000000,"0")]
        ++ testCasts Bits64 Integer [(0,0),(0xffffffffffffffff,0xffffffffffffffff),(0x10000000000000000,0)]
        ++ testCasts Bits64 Bits8   [(0,0),(0xffffffffffffffff,0xff),(0x10000000000000000,0)]
        ++ testCasts Bits64 Bits16  [(0,0),(0xffffffffffffffff,0xffff),(0x10000000000000000,0)]
        ++ testCasts Bits64 Bits32  [(0,0),(0xffffffffffffffff,0xffffffff),(0x10000000000000000,0)]

        ++ testCasts String Int8    [("-129",127),("-128",-128),("0",0),("127",127), ("128",-128)]
        ++ testCasts String Int16   [("-32769",32767),("-32768",-32768),("0",0),("32767",32767), ("32768",-32768)]
        ++ testCasts String Int32   [("-2147483649",2147483647),("-2147483648",-2147483648),("0",0),("2147483647",2147483647), ("2147483648",-2147483648)]
        ++ testCasts String Int64   [("-9223372036854775809",9223372036854775807),("-9223372036854775808",-9223372036854775808),("0",0),("9223372036854775807",9223372036854775807), ("9223372036854775808",-9223372036854775808)]
        ++ testCasts String Int     [("-9223372036854775809",9223372036854775807),("-9223372036854775808",-9223372036854775808),("0",0),("9223372036854775807",9223372036854775807), ("9223372036854775808",-9223372036854775808)]
        ++ testCasts String Integer [("-170141183460469231731687303715884105728",-170141183460469231731687303715884105728),("-170141183460469231731687303715884105728",-170141183460469231731687303715884105728),("0",0),("170141183460469231731687303715884105728",170141183460469231731687303715884105728)]
        ++ testCasts String Bits8   [("0",0),("255",255), ("256",0)]
        ++ testCasts String Bits16  [("0",0),("65535",65535), ("65536",0)]
        ++ testCasts String Bits32  [("0",0),("4294967295",4294967295), ("4294967296",0)]
        ++ testCasts String Bits64  [("0",0),("18446744073709551615",18446744073709551615), ("18446744073709551616",0)]

        ++ testCasts Double Int8    [(-129.0, 127),(-128.0,-128),(-12.001,-12),(12.001,12),(127.0,127),(128.0,-128)]
        ++ testCasts Double Int16   [(-32769.0, 32767),(-32768.0,-32768),(-12.001,-12),(12.001,12),(32767.0,32767),(32768.0,-32768)]
        ++ testCasts Double Int32   [(-2147483649.0,2147483647),(-2147483648.0,-2147483648),(-12.001,-12),(12.001,12),(2147483647.0,2147483647),(2147483648.0,-2147483648)]
        ++ testCasts Double Int64   [(-9223372036854775808.0,-9223372036854775808),(-12.001,-12),(12.001,12),(9223372036854775808.0,-9223372036854775808)]
        ++ testCasts Double Int     [(-9223372036854775808.0,-9223372036854775808),(-12.001,-12),(12.001,12),(9223372036854775808.0,-9223372036854775808)]
        ++ testCasts Double Bits8   [(0.0,0),(255.0,255), (256.0,0)]
        ++ testCasts Double Bits16  [(0.0,0),(65535.0,65535), (65536.0,0)]
        ++ testCasts Double Bits32  [(0.0,0),(4294967295.0,4294967295), (4294967296.0,0)]
        ++ testCasts Double Bits64  [(0.0,0),(18446744073709551616.0,0)]

        ++ testCasts Int8 Char    [(-1, '\x0'), (80, 'P')]
        ++ testCasts Int16 Char   [(-1, '\x0'), (80, 'P')]
        ++ testCasts Int32 Char   [(-1, '\x0'), (80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000'), (1114111, '\x10ffff'), (1114112, '\x0')]
        ++ testCasts Int64 Char   [(-1, '\x0'), (80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000'), (1114111, '\x10ffff'), (1114112, '\x0')]
        ++ testCasts Int   Char   [(-1, '\x0'), (80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000'), (1114111, '\x10ffff'), (1114112, '\x0')]
        ++ testCasts Bits8 Char   [(80, 'P')]
        ++ testCasts Bits16 Char  [(80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000')]
        ++ testCasts Bits32 Char  [(80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000'), (1114111, '\x10ffff'), (1114112, '\x0')]
        ++ testCasts Bits64 Char  [(80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000'), (1114111, '\x10ffff'), (1114112, '\x0')]
        ++ testCasts Integer Char [(-1, '\x0'), (80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000'), (1114111, '\x10ffff'), (1114112, '\x0')]

--------------------------------------------------------------------------------
--          Main
--------------------------------------------------------------------------------

main : IO ()
main = traverse_ putStrLn results


module Data.IntMap

-- Hand specialised map, for efficiency...

%default total

Key : Type
Key = Int

-- TODO: write split

private
data Tree : Nat -> Type -> Type where
  Leaf : Key -> v -> Tree Z v
  Branch2 : Tree n v -> Key -> Tree n v -> Tree (S n) v
  Branch3 : Tree n v -> Key -> Tree n v -> Key -> Tree n v -> Tree (S n) v

branch4 :
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v ->
  Tree (S (S n)) v
branch4 a b c d e f g =
  Branch2 (Branch2 a b c) d (Branch2 e f g)

branch5 :
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v ->
  Tree (S (S n)) v
branch5 a b c d e f g h i =
  Branch2 (Branch2 a b c) d (Branch3 e f g h i)

branch6 :
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v ->
  Tree (S (S n)) v
branch6 a b c d e f g h i j k =
  Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)

branch7 :
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v -> Key ->
  Tree n v ->
  Tree (S (S n)) v
branch7 a b c d e f g h i j k l m =
  Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)

merge1 : Tree n v -> Key -> Tree (S n) v -> Key -> Tree (S n) v -> Tree (S (S n)) v
merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i
merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k
merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k
merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

merge2 : Tree (S n) v -> Key -> Tree n v -> Key -> Tree (S n) v -> Tree (S (S n)) v
merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i
merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k
merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k
merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

merge3 : Tree (S n) v -> Key -> Tree (S n) v -> Key -> Tree n v -> Tree (S (S n)) v
merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i
merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k
merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k
merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m

treeLookup : Key -> Tree n v -> Maybe v
treeLookup k (Leaf k' v) =
  if k == k' then
    Just v
  else
    Nothing
treeLookup k (Branch2 t1 k' t2) =
  if k <= k' then
    treeLookup k t1
  else
    treeLookup k t2
treeLookup k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    treeLookup k t1
  else if k <= k2 then
    treeLookup k t2
  else
    treeLookup k t3

treeInsert' : Key -> v -> Tree n v -> Either (Tree n v) (Tree n v, Key, Tree n v)
treeInsert' k v (Leaf k' v') =
  case compare k k' of
    LT => Right (Leaf k v, k, Leaf k' v')
    EQ => Left (Leaf k v)
    GT => Right (Leaf k' v', k', Leaf k v)
treeInsert' k v (Branch2 t1 k' t2) =
  if k <= k' then
    case treeInsert' k v t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right (a, b, c) => Left (Branch3 a b c k' t2)
  else
    case treeInsert' k v t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right (a, b, c) => Left (Branch3 t1 k' a b c)
treeInsert' k v (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeInsert' k v t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3)
  else
    if k <= k2 then
      case treeInsert' k v t2 of
        Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
        Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3)
    else
      case treeInsert' k v t3 of
        Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
        Right (a, b, c) => Right (Branch2 t1 k1 t2, k2, Branch2 a b c)

treeInsert : Key -> v -> Tree n v -> Either (Tree n v) (Tree (S n) v)
treeInsert k v t =
  case treeInsert' k v t of
    Left t' => Left t'
    Right (a, b, c) => Right (Branch2 a b c)

delType : Nat -> Type -> Type
delType Z v = ()
delType (S n) v = Tree n v

treeDelete : {n : _} -> Key -> Tree n v -> Either (Tree n v) (delType n v)
treeDelete k (Leaf k' v) =
  if k == k' then
    Right ()
  else
    Left (Leaf k' v)
treeDelete {n=S Z} k (Branch2 t1 k' t2) =
  if k <= k' then
    case treeDelete k t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right () => Right t2
  else
    case treeDelete k t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right () => Right t1
treeDelete {n=S Z} k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeDelete k t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right () => Left (Branch2 t2 k2 t3)
  else if k <= k2 then
    case treeDelete k t2 of
      Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
      Right () => Left (Branch2 t1 k1 t3)
  else
    case treeDelete k t3 of
      Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
      Right () => Left (Branch2 t1 k1 t2)
treeDelete {n=S (S _)} k (Branch2 t1 k' t2) =
  if k <= k' then
    case treeDelete k t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right t1' =>
        case t2 of
          Branch2 a b c => Right (Branch3 t1' k' a b c)
          Branch3 a b c d e => Left (branch4 t1' k' a b c d e)
  else
    case treeDelete k t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right t2' =>
        case t1 of
          Branch2 a b c => Right (Branch3 a b c k' t2')
          Branch3 a b c d e => Left (branch4 a b c d e k' t2')
treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeDelete k t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right t1' => Left (merge1 t1' k1 t2 k2 t3)
  else if k <= k2 then
    case treeDelete k t2 of
      Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
      Right t2' => Left (merge2 t1 k1 t2' k2 t3)
  else
    case treeDelete k t3 of
      Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
      Right t3' => Left (merge3 t1 k1 t2 k2 t3')

treeToList : Tree n v -> List (Key, v)
treeToList = treeToList' []
  where
    treeToList' : forall n . List (Key, v) -> Tree n v -> List (Key, v)
    treeToList' rest (Leaf k v) = (k, v) :: rest
    treeToList' rest (Branch2 t1 _ t2)
        = treeToList' (treeToList' rest t2) t1
    treeToList' rest (Branch3 t1 _ t2 _ t3)
        = treeToList' (treeToList' (treeToList' rest t3) t2) t1

export
data IntMap : Type -> Type where
  Empty : IntMap v
  M : (n : Nat) -> Tree n v -> IntMap v

export
empty : IntMap v
empty = Empty

export
lookup : Int -> IntMap v -> Maybe v
lookup _ Empty = Nothing
lookup k (M _ t) = treeLookup k t

export
insert : Int -> v -> IntMap v -> IntMap v
insert k v Empty = M Z (Leaf k v)
insert k v (M _ t) =
  case treeInsert k v t of
    Left t' => (M _ t')
    Right t' => (M _ t')

export
insertFrom : List (Int, v) -> IntMap v -> IntMap v
insertFrom = flip $ foldl $ flip $ uncurry insert

export
delete : Int -> IntMap v -> IntMap v
delete _ Empty = Empty
delete k (M Z t) =
  case treeDelete k t of
    Left t' => (M _ t')
    Right () => Empty
delete k (M (S _) t) =
  case treeDelete k t of
    Left t' => (M _ t')
    Right t' => (M _ t')

export
fromList : List (Int, v) -> IntMap v
fromList l = foldl (flip (uncurry insert)) empty l

export
toList : IntMap v -> List (Int, v)
toList Empty = []
toList (M _ t) = treeToList t

||| Gets the Keys of the map.
export
keys : IntMap v -> List Int
keys = map fst . toList

||| Gets the values of the map. Could contain duplicates.
export
values : IntMap v -> List v
values = map snd . toList

treeMap : (a -> b) -> Tree n a -> Tree n b
treeMap f (Leaf k v) = Leaf k (f v)
treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)
treeMap f (Branch3 t1 k1 t2 k2 t3)
    = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3)

export
implementation Functor IntMap where
  map _ Empty = Empty
  map f (M n t) = M _ (treeMap f t)

||| Merge two maps. When encountering duplicate keys, using a function to combine the values.
||| Uses the ordering of the first map given.
export
mergeWith : (v -> v -> v) -> IntMap v -> IntMap v -> IntMap v
mergeWith f x y = insertFrom inserted x where
  inserted : List (Key, v)
  inserted = do
    (k, v) <- toList y
    let v' = (maybe id f $ lookup k x) v
    pure (k, v')

||| Merge two maps using the Semigroup (and by extension, Monoid) operation.
||| Uses mergeWith internally, so the ordering of the left map is kept.
export
merge : Semigroup v => IntMap v -> IntMap v -> IntMap v
merge = mergeWith (<+>)

||| Left-biased merge, also keeps the ordering specified  by the left map.
export
mergeLeft : IntMap v -> IntMap v -> IntMap v
mergeLeft = mergeWith const

-- TODO: is this the right variant of merge to use for this? I think it is, but
-- I could also see the advantages of using `mergeLeft`. The current approach is
-- strictly more powerful I believe, because `mergeLeft` can be emulated with
-- the `First` monoid. However, this does require more code to do the same
-- thing.
export
Semigroup v => Semigroup (IntMap v) where
  (<+>) = merge

export
(Semigroup v) => Monoid (IntMap v) where
  neutral = empty


module Select

-- Based on http://eptcs.web.cse.unsw.edu.au/paper.cgi?MSFP2014.3.pdf
--          https://downloads.haskell.org/~ghc/latest/docs/html/libraries/transformers-0.5.6.2/src/Control-Monad-Trans-Select.html#SelectT

import Data.Vect
import Control.Monad.Identity
import Control.Monad.Trans

data SelectT : (r : Type) -> (m : Type -> Type) -> (a : Type) -> Type where
  Sel : ((a -> m r) -> m a) -> SelectT r m a

Select : Type -> Type -> Type
Select a r = SelectT r Identity a

Functor m => Functor (SelectT r m) where
  map f (Sel g) = Sel (\k => map f $ g (k . f))

Monad m => Applicative (SelectT r m) where
  pure a = Sel (\k => pure a)

  (Sel gf) <*> (Sel g) = Sel $ \k => do f <- gf (\f => h f k >>= k)
                                        h f k
    where
     h : (a -> b) -> (b -> m r) -> m b
     h f k = map f $ g (k . f)

Monad m => Monad (SelectT r m) where
  (Sel g) >>= f = Sel $ \k => do a <- g (\a => h a k >>= k)
                                 h a k
    where
      h : a -> (b -> m r) -> m b
      h a k = let (Sel g') = f a in g' k

MonadTrans (SelectT r) where
  lift m = Sel (\k => m)

boundedBinarySearch : Monad m => (n : Nat) -> SelectT Bool m (Vect n Bool)
boundedBinarySearch n = sequence $ replicate n $ Sel (\k => k True)