||| Specialized implementation of an interval map with finger trees [1].
||| This data structure is meant to get efficiently data with a correlated NonEmptyFC.
||| The element data type must implement the `Measure` interface. An implementation
||| is provided already for NonEmptyFC and tuples with NonEmptyFC as first element.
|||
||| [1] https://www.staff.city.ac.uk/~ross/papers/FingerTree.pdf
module Libraries.Data.PosMap

import Core.FC

import Data.List

%default total

infixr 5 <|, <:
infixl 5 |>, :>

public export
FileRange : Type
FileRange = (FilePos, FilePos)

||| Type for rightmost intervals, ordered by their low endpoints and annotated
||| with the maximum of the high endpoints.
data RMFileRange = MkRange FileRange FilePos

Eq RMFileRange where
  (MkRange low high) == (MkRange low' high') = low == low' && high == high'

Show RMFileRange where
  showPrec p (MkRange low high) = showCon p "MkRange" $ showArg low ++ showArg high

Semigroup RMFileRange where
  -- The semigroup operation on righmost intervals is the composition of two
  -- monoids applied to each component:
  -- 1) the operation on low endpoints always returns the last key it contains,
  --    assuming the keys are ordered (enforced by the insertion function), the
  --    FingerTree behaves as a store of ordered sequences, with measures
  --    serving as signpost keys.
  -- 2) the operation on high endpoints returns the maximum of the endpoints,
  --    thus the FingerTree behaves as a max-priority queue.
  (MkRange low high) <+> (MkRange low' high') = MkRange low' (max high high')

data Interval = MkInterval RMFileRange | NoInterval

Eq Interval where
  (MkInterval range) == (MkInterval range') = range == range'
  NoInterval == NoInterval = True
  _ == _ = False

Show Interval where
  showPrec p (MkInterval range) = showCon p "MkInterval" $ showArg range
  showPrec p NoInterval = "NoInterval"

Semigroup Interval where
  NoInterval <+> i = i
  i <+> NoInterval = i
  (MkInterval range) <+> (MkInterval range') = MkInterval (range <+> range')

Monoid Interval where
  neutral = NoInterval

Cast FileRange RMFileRange where
  cast (l, h) = MkRange (l, h) h

Cast FileRange Interval where
  cast (l, h) = MkInterval (MkRange (l, h) h)

Cast RMFileRange Interval where
  cast = MkInterval

||| Things that have an associated interval in the source files.
public export
interface Measure a where
  measure : a -> FileRange

interface MeasureRM a where
  measureRM : a -> RMFileRange

public export
Measure a => MeasureRM a where
  measureRM = cast . measure

measureInterval : Measure a => a -> Interval
measureInterval = cast . measure

data Digit : Type -> Type where
  One : a -> Digit a
  Two : a -> a -> Digit a
  Three : a -> a -> a -> Digit a
  Four : a -> a -> a -> a -> Digit a

Eq a => Eq (Digit a) where
  (One x) == (One x') = x == x'
  (Two x y) == (Two x' y') = x == x' && y == y'
  (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'
  (Four x y z w) == (Four x' y' z' w') = x == x' && y == y' && z == z' && w == w'
  _ == _ = False

Show a => Show (Digit a) where
  showPrec p (One x) = showCon p "One" $ showArg x
  showPrec p (Two x y) = showCon p "Two" $ showArg x ++ showArg y
  showPrec p (Three x y z) = showCon p "Three" $ showArg x ++ showArg y ++ showArg z
  showPrec p (Four x y z w) = showCon p "Four" $ showArg x ++ showArg y ++ showArg z ++ showArg w

Functor Digit where
  map f (One x) = One (f x)
  map f (Two x y) = Two (f x) (f y)
  map f (Three x y z) = Three (f x) (f y) (f z)
  map f (Four x y z w) = Four (f x) (f y) (f z) (f w)

Foldable Digit where
  foldr f init (One a) = f a init
  foldr f init (Two a b) = f a (f b init)
  foldr f init (Three a b c) = f a (f b (f c init))
  foldr f init (Four a b c d) = f a (f b (f c (f d init)))

  foldl f init (One a) = f init a
  foldl f init (Two a b) = f (f init a) b
  foldl f init (Three a b c) = f (f (f init a) b) c
  foldl f init (Four a b c d) = f (f (f (f init a) b) c) d

  null _ = False

Traversable Digit where
  traverse f (One x) = [| One (f x) |]
  traverse f (Two x y) = [| Two (f x) (f y) |]
  traverse f (Three x y z) = [| Three (f x) (f y) (f z) |]
  traverse f (Four x y z w) = [| Four (f x) (f y) (f z) (f w) |]

MeasureRM a => MeasureRM (Digit a) where
  measureRM (One x) = measureRM x
  measureRM (Two x y) = measureRM x <+> measureRM y
  measureRM (Three x y z) = measureRM x <+> measureRM y <+> measureRM z
  measureRM (Four x y z w) = measureRM x <+> measureRM y <+> measureRM z <+> measureRM w

data Node : Type -> Type where
  Node2 : RMFileRange -> a -> a -> Node a
  Node3 : RMFileRange -> a -> a -> a -> Node a

node2 : MeasureRM a => a -> a -> Node a
node2 x y = Node2 (measureRM x <+> measureRM y) x y

node3 : MeasureRM a => a -> a -> a -> Node a
node3 x y z = Node3 (measureRM x <+> measureRM y <+> measureRM z) x y z

Foldable Node where
  foldr f init (Node2 _ x y) = f x (f y init)
  foldr f init (Node3 _ x y z) = f x (f y (f z init))

  foldl f init (Node2 v a b) = f (f init a) b
  foldl f init (Node3 v a b c) = f (f (f init a) b) c

MeasureRM (Node a) where
  measureRM (Node2 v {}) = v
  measureRM (Node3 v {}) = v

namespace Node
  export
  map : MeasureRM b => (a -> b) -> Node a -> Node b
  map f (Node2 _ x y) = node2 (f x) (f y)
  map f (Node3 _ x y z) = node3 (f x) (f y) (f z)

  export
  traverse : (Applicative f, MeasureRM b) => (a -> f b) -> Node a -> f (Node b)
  traverse f (Node2 _ x y) = [| node2 (f x) (f y) |]
  traverse f (Node3 _ x y z) = [| node3 (f x) (f y) (f z) |]

nodeToDigit : MeasureRM a => Node a -> Digit a
nodeToDigit (Node2 _ x y) = Two x y
nodeToDigit (Node3 _ x y z) = Three x y z

export
data PosMap : Type -> Type where
  Empty : PosMap a
  Single : a -> PosMap a
  Deep : RMFileRange -> Digit a -> PosMap (Node a) -> Digit a -> PosMap a

measureTree : MeasureRM a => PosMap a -> Interval
measureTree Empty = neutral
measureTree (Single x) = cast (measureRM x)
measureTree (Deep v {}) = cast v

addIntervalRight : RMFileRange -> Interval -> RMFileRange
addIntervalRight range (MkInterval range') = range <+> range'
addIntervalRight range NoInterval = range

addIntervalLeft : Interval -> RMFileRange -> RMFileRange
addIntervalLeft (MkInterval range) range' = range <+> range'
addIntervalLeft NoInterval range' = range'

deep : MeasureRM a => Digit a -> PosMap (Node a) -> Digit a -> PosMap a
deep pr t sf = Deep value pr t sf
  where value : RMFileRange
        value = case measureTree t of
                     MkInterval range => measureRM pr <+> range <+> measureRM sf
                     NoInterval => measureRM pr <+> measureRM sf

digitToTree : MeasureRM a => Digit a -> PosMap a
digitToTree (One a) = Single a
digitToTree (Two a b) = deep (One a) Empty (One b)
digitToTree (Three a b c) = deep (Two a b) Empty (One c)
digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)

(<|) : MeasureRM a => a -> PosMap a -> PosMap a
a <| Empty                        = Single a
a <| (Single b)                   = deep (One a) Empty (One b)
a <| (Deep _ (One b) m sf)        = deep (Two a b) m sf
a <| (Deep _ (Two b c) m sf)      = deep (Three a b c) m sf
a <| (Deep _ (Three b c d) m sf)  = deep (Four a b c d) m sf
a <| (Deep _ (Four b c d e) m sf) = deep (Two a b) (node3 c d e <| m) sf

(|>) : MeasureRM a => PosMap a -> a -> PosMap a
Empty                        |> a = Single a
(Single b)                   |> a = deep (One b) Empty (One a)
(Deep _ pr m (One b))        |> a = deep pr m (Two b a)
(Deep _ pr m (Two c b))      |> a = deep pr m (Three c b a)
(Deep _ pr m (Three d c b))  |> a = deep pr m (Four d c b a)
(Deep _ pr m (Four e d c b)) |> a = deep pr (m |> node3 e d c) (Two b a)

export
Foldable PosMap where
  foldr f init Empty = init
  foldr f init (Single x) = f x init
  foldr f init (Deep _ pr m sf) = foldr f (foldr (flip (foldr f)) (foldr f init sf) m) pr

  foldl f init Empty = init
  foldl f init (Single x) = f init x
  foldl f init (Deep _ pr m sf) = foldl f (foldl (foldl f) (foldl f init pr) m) sf

  null Empty = True
  null (Single {}) = False
  null (Deep {}) = False

export
empty : PosMap a
empty = Empty

export
singleton : a -> PosMap a
singleton x = Single x

toTree : (Foldable f, MeasureRM a) => f a -> PosMap a
toTree xs = foldr (<|) empty xs

data ViewL : Type -> Type where
  EmptyL : ViewL a
  (<:) : a -> PosMap a -> ViewL a

rotl : MeasureRM a => PosMap (Node a) -> Digit a -> PosMap a
viewl : MeasureRM a => PosMap a -> ViewL a

rotl t sf =
  case viewl t of
       EmptyL => digitToTree sf
       a <: t' => case measureTree t of
                       MkInterval range => Deep (range <+> measureRM sf) (nodeToDigit a) t' sf
                       NoInterval => Deep (measureRM sf) (nodeToDigit a) t' sf

viewl Empty = EmptyL
viewl (Single x) = x <: Empty
viewl (Deep _ (One x) t sf) = x <: rotl t sf
viewl (Deep _ (Two x y) t sf) = x <: deep (One y) t sf
viewl (Deep _ (Three x y z) t sf) = x <: deep (Two y z) t sf
viewl (Deep _ (Four x y z w) t sf) = x <: deep (Three y z w) t sf

data ViewR : Type -> Type where
  EmptyR : ViewR a
  (:>) : PosMap a -> a -> ViewR a

rotr : MeasureRM a => Digit a -> PosMap (Node a) -> PosMap a
viewr : MeasureRM a => PosMap a -> ViewR a

rotr pr t =
  case viewr t of
       EmptyR => digitToTree pr
       t' :> a => case measureTree t of
                       MkInterval range => Deep (measureRM pr <+> range) pr t' (nodeToDigit a)
                       NoInterval => Deep (measureRM pr) pr t' (nodeToDigit a)

viewr Empty = EmptyR
viewr (Single x) = Empty :> x
viewr (Deep _ pr t (One x)) = rotr pr t :> x
viewr (Deep _ pr t (Two x y)) = deep pr t (One x) :> y
viewr (Deep _ pr t (Three x y z)) = deep pr t (Two x y) :> z
viewr (Deep _ pr t (Four x y z w)) = deep pr t (Three x y z) :> w

appendTree0 : MeasureRM a => PosMap a -> PosMap a -> PosMap a
appendTree1 : MeasureRM a => PosMap a -> a -> PosMap a -> PosMap a
appendTree2 : MeasureRM a => PosMap a -> a -> a -> PosMap a -> PosMap a
appendTree3 : MeasureRM a => PosMap a -> a -> a -> a -> PosMap a -> PosMap a
appendTree4 : MeasureRM a => PosMap a -> a -> a -> a -> a -> PosMap a -> PosMap a
addDigits0  : MeasureRM a => PosMap (Node a) -> Digit a -> Digit a -> PosMap (Node a) -> PosMap (Node a)
addDigits1  : MeasureRM a => PosMap (Node a) -> Digit a -> a -> Digit a -> PosMap (Node a) -> PosMap (Node a)
addDigits2  : MeasureRM a => PosMap (Node a) -> Digit a -> a -> a -> Digit a -> PosMap (Node a) -> PosMap (Node a)
addDigits3  : MeasureRM a => PosMap (Node a) -> Digit a -> a -> a -> a -> Digit a -> PosMap (Node a) -> PosMap (Node a)
addDigits4  : MeasureRM a => PosMap (Node a) -> Digit a -> a -> a -> a -> a -> Digit a -> PosMap (Node a) -> PosMap (Node a)

appendTree0 Empty xs = xs
appendTree0 xs Empty = xs
appendTree0 (Single x) xs = x <| xs
appendTree0 xs (Single x) = xs |> x
appendTree0 (Deep _ pr1 t1 sf1) (Deep _ pr2 t2 sf2) = deep pr1 (addDigits0 t1 sf1 pr2 t2) sf2

appendTree1 Empty a xs = a <| xs
appendTree1 xs a Empty = xs |> a
appendTree1 (Single x) a xs = x <| a <| xs
appendTree1 xs a (Single x) = xs |> a |> x
appendTree1 (Deep _ pr1 t1 sf1) a (Deep _ pr2 t2 sf2) = deep pr1 (addDigits1 t1 sf1 a pr2 t2) sf2

appendTree2 Empty a b xs = a <| b <| xs
appendTree2 xs a b Empty = xs |> a |> b
appendTree2 (Single x) a b xs = x <| a <| b <| xs
appendTree2 xs a b (Single x) = xs |> a |> b |> x
appendTree2 (Deep _ pr1 t1 sf1) a b (Deep _ pr2 t2 sf2) = deep pr1 (addDigits2 t1 sf1 a b pr2 t2) sf2

appendTree3 Empty a b c xs = a <| b <| c <| xs
appendTree3 xs a b c Empty = xs |> a |> b |> c
appendTree3 (Single x) a b c xs = x <| a <| b <| c <| xs
appendTree3 xs a b c (Single x) = xs |> a |> b |> c |> x
appendTree3 (Deep _ pr1 t1 sf1) a b c (Deep _ pr2 t2 sf2) = deep pr1 (addDigits3 t1 sf1 a b c pr2 t2) sf2

appendTree4 Empty a b c d xs = a <| b <| c <| d <| xs
appendTree4 xs a b c d Empty = xs |> a |> b |> c |> d
appendTree4 (Single x) a b c d xs = a <| b <| c <| d <| x <| xs
appendTree4 xs a b c d (Single x) = xs |> a |> b |> c |> d |> x
appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) = deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2

addDigits0 t1 (One a)        (One b)        t2 = appendTree1 t1 (node2 a b) t2
addDigits0 t1 (One a)        (Two b c)      t2 = appendTree1 t1 (node3 a b c) t2
addDigits0 t1 (One a)        (Three b c d)  t2 = appendTree2 t1 (node2 a b) (node2 c d) t2
addDigits0 t1 (One a)        (Four b c d e) t2 = appendTree2 t1 (node3 a b c) (node2 d e) t2
addDigits0 t1 (Two a b)      (One c)        t2 = appendTree1 t1 (node3 a b c) t2
addDigits0 t1 (Two a b)      (Two c d)      t2 = appendTree2 t1 (node2 a b) (node2 c d) t2
addDigits0 t1 (Two a b)      (Three c d e)  t2 = appendTree2 t1 (node3 a b c) (node2 d e) t2
addDigits0 t1 (Two a b)      (Four c d e f) t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits0 t1 (Three a b c)  (One d)        t2 = appendTree2 t1 (node2 a b) (node2 c d) t2
addDigits0 t1 (Three a b c)  (Two d e)      t2 = appendTree2 t1 (node3 a b c) (node2 d e) t2
addDigits0 t1 (Three a b c)  (Three d e f)  t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits0 t1 (Three a b c)  (Four d e f g) t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits0 t1 (Four a b c d) (One e)        t2 = appendTree2 t1 (node3 a b c) (node2 d e) t2
addDigits0 t1 (Four a b c d) (Two e f)      t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits0 t1 (Four a b c d) (Three e f g)  t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits0 t1 (Four a b c d) (Four e f g h) t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2

addDigits1 t1 (One a)        b (One c)        t2 = appendTree1 t1 (node3 a b c) t2
addDigits1 t1 (One a)        b (Two c d)      t2 = appendTree2 t1 (node2 a b) (node2 c d) t2
addDigits1 t1 (One a)        b (Three c d e)  t2 = appendTree2 t1 (node3 a b c) (node2 d e) t2
addDigits1 t1 (One a)        b (Four c d e f) t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits1 t1 (Two a b)      c (One d)        t2 = appendTree2 t1 (node2 a b) (node2 c d) t2
addDigits1 t1 (Two a b)      c (Two d e)      t2 = appendTree2 t1 (node3 a b c) (node2 d e) t2
addDigits1 t1 (Two a b)      c (Three d e f)  t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits1 t1 (Two a b)      c (Four d e f g) t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits1 t1 (Three a b c)  d (One e)        t2 = appendTree2 t1 (node3 a b c) (node2 d e) t2
addDigits1 t1 (Three a b c)  d (Two e f)      t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits1 t1 (Three a b c)  d (Three e f g)  t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits1 t1 (Three a b c)  d (Four e f g h) t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2
addDigits1 t1 (Four a b c d) e (One f)        t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits1 t1 (Four a b c d) e (Two f g)      t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits1 t1 (Four a b c d) e (Three f g h)  t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2
addDigits1 t1 (Four a b c d) e (Four f g h i) t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node3 g h i) t2

addDigits2 t1 (One a)        b c (One d)        t2 = appendTree2 t1 (node2 a b) (node2 c d) t2
addDigits2 t1 (One a)        b c (Two d e)      t2 = appendTree2 t1 (node3 a b c) (node2 d e) t2
addDigits2 t1 (One a)        b c (Three d e f)  t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits2 t1 (One a)        b c (Four d e f g) t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits2 t1 (Two a b)      c d (One e)        t2 = appendTree2 t1 (node3 a b c) (node2 d e) t2
addDigits2 t1 (Two a b)      c d (Two e f)      t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits2 t1 (Two a b)      c d (Three e f g)  t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits2 t1 (Two a b)      c d (Four e f g h) t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2
addDigits2 t1 (Three a b c)  d e (One f)        t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits2 t1 (Three a b c)  d e (Two f g)      t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits2 t1 (Three a b c)  d e (Three f g h)  t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2
addDigits2 t1 (Three a b c)  d e (Four f g h i) t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node3 g h i) t2
addDigits2 t1 (Four a b c d) e f (One g)        t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits2 t1 (Four a b c d) e f (Two g h)      t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2
addDigits2 t1 (Four a b c d) e f (Three g h i)  t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node3 g h i) t2
addDigits2 t1 (Four a b c d) e f (Four g h i j) t2 = appendTree4 t1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) t2

addDigits3 t1 (One a)        b c d (One e)        t2 = appendTree2 t1 (node3 a b c) (node2 d e) t2
addDigits3 t1 (One a)        b c d (Two e f)      t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits3 t1 (One a)        b c d (Three e f g)  t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits3 t1 (One a)        b c d (Four e f g h) t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2
addDigits3 t1 (Two a b)      c d e (One f)        t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits3 t1 (Two a b)      c d e (Two f g)      t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits3 t1 (Two a b)      c d e (Three f g h)  t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2
addDigits3 t1 (Two a b)      c d e (Four f g h i) t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node3 g h i) t2
addDigits3 t1 (Three a b c)  d e f (One g)        t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits3 t1 (Three a b c)  d e f (Two g h)      t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2
addDigits3 t1 (Three a b c)  d e f (Three g h i)  t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node3 g h i) t2
addDigits3 t1 (Three a b c)  d e f (Four g h i j) t2 = appendTree4 t1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) t2
addDigits3 t1 (Four a b c d) e f g (One h)        t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2
addDigits3 t1 (Four a b c d) e f g (Two h i)      t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node3 g h i) t2
addDigits3 t1 (Four a b c d) e f g (Three h i j)  t2 = appendTree4 t1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) t2
addDigits3 t1 (Four a b c d) e f g (Four h i j k) t2 = appendTree4 t1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) t2

addDigits4 t1 (One a)        b c d e (One f)        t2 = appendTree2 t1 (node3 a b c) (node3 d e f) t2
addDigits4 t1 (One a)        b c d e (Two f g)      t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits4 t1 (One a)        b c d e (Three f g h)  t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2
addDigits4 t1 (One a)        b c d e (Four f g h i) t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node3 g h i) t2
addDigits4 t1 (Two a b)      c d e f (One g)        t2 = appendTree3 t1 (node3 a b c) (node2 d e) (node2 f g) t2
addDigits4 t1 (Two a b)      c d e f (Two g h)      t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2
addDigits4 t1 (Two a b)      c d e f (Three g h i)  t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node3 g h i) t2
addDigits4 t1 (Two a b)      c d e f (Four g h i j) t2 = appendTree4 t1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) t2
addDigits4 t1 (Three a b c)  d e f g (One h)        t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node2 g h) t2
addDigits4 t1 (Three a b c)  d e f g (Two h i)      t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node3 g h i) t2
addDigits4 t1 (Three a b c)  d e f g (Three h i j)  t2 = appendTree4 t1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) t2
addDigits4 t1 (Three a b c)  d e f g (Four h i j k) t2 = appendTree4 t1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) t2
addDigits4 t1 (Four a b c d) e f g h (One i)        t2 = appendTree3 t1 (node3 a b c) (node3 d e f) (node3 g h i) t2
addDigits4 t1 (Four a b c d) e f g h (Two i j)      t2 = appendTree4 t1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) t2
addDigits4 t1 (Four a b c d) e f g h (Three i j k)  t2 = appendTree4 t1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) t2
addDigits4 t1 (Four a b c d) e f g h (Four i j k l) t2 = appendTree4 t1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) t2

Split : Type -> Type -> Type
Split t a = (t, a, t)

data SearchResult : Type -> Type where
  Position : PosMap a -> a -> PosMap a -> SearchResult a
  OnLeft : SearchResult a
  OnRight : SearchResult a
  Nowhere : SearchResult a

searchDigit : MeasureRM a => (Interval -> Interval -> Bool) -> Interval -> Digit a -> Interval -> Split (Maybe (Digit a)) a
searchDigit p vl (One a) vr = (Nothing, a, Nothing)
searchDigit p vl (Two a b) vr =
  let va = vl <+> cast (measureRM a)
      vb = cast (measureRM b) <+> vr in
      if p va vb
         then (Nothing, a, Just (One b))
         else (Just (One a), b, Nothing)
searchDigit p vl (Three a b c) vr =
  let va  = vl <+> cast (measureRM a)
      vab = va <+> cast (measureRM b)
      vc  = cast (measureRM c) <+> vr
      vbc = cast (measureRM b) <+> vc in
      if p va vbc
         then (Nothing, a, Just (Two b c))
         else if p vab vc
                 then (Just (One a), b, Just (One c))
                 else (Just (Two a b), c, Nothing)
searchDigit p vl (Four a b c d) vr =
  let va   = vl <+> cast (measureRM a)
      vab  = va <+> cast (measureRM b)
      vabc = vab <+> cast (measureRM c)
      vd   = cast (measureRM d) <+> vr
      vcd  = cast (measureRM c) <+> vd
      vbcd = cast (measureRM b) <+> vcd in
      if p va vbcd
         then (Nothing, a, Just (Three b c d))
         else if p vab vcd
                 then (Just (One a), b, Just (Two c d))
                 else if p vabc vd
                         then (Just (Two a b), c, Just (One d))
                         else (Just (Three a b c), d, Nothing)

deepl : MeasureRM a => Maybe (Digit a) -> PosMap (Node a) -> Digit a -> PosMap a
deepl Nothing m sf = rotl m sf
deepl (Just pr) m sf = deep pr m sf

deepr : MeasureRM a => Digit a -> PosMap (Node a) -> Maybe (Digit a) -> PosMap a
deepr pr m Nothing = rotr pr m
deepr pr m (Just sf) = deep pr m sf

searchNode : MeasureRM a => (Interval -> Interval -> Bool) -> Interval -> Node a -> Interval -> Split (Maybe (Digit a)) a
searchNode p vl x vr = searchDigit p vl (nodeToDigit x) vr

searchTree : MeasureRM a => (Interval -> Interval -> Bool) -> Interval -> PosMap a -> Interval -> Maybe (Split (PosMap a) a)
searchTree p vl Empty vr = Nothing
searchTree p vl (Single x) vr = Just (Empty, x, Empty)
searchTree p vl (Deep _ pr m sf) vr =
  let vm   = measureTree m
      vsr  = cast (measureRM sf) <+> vr
      vmsr = vm <+> vsr
      vlp  = vl <+> cast (measureRM pr)
      vlpm = vlp <+> vm in
      if p vlp vmsr
         then let (l, x, r) = searchDigit p vl pr vmsr in
                  Just (maybe Empty digitToTree l, x, deepl r m sf)
         else if p vlpm vsr
                 then do (ml, xs, mr) <- searchTree p vlp m vsr
                         let (l, x, r) = searchNode p (vlp <+> measureTree ml) xs (measureTree mr <+> vsr)
                         Just (deepr pr ml l, x, deepl r mr sf)
                 else let (l, x, r) = searchDigit p vlpm sf vr in
                          Just (deepr pr m l, x, maybe Empty digitToTree r)

search' : MeasureRM a => (Interval -> Interval -> Bool) -> PosMap a -> SearchResult a
search' p t =
  let vt     = measureTree t
      pLeft  = p neutral vt
      pRight = p vt neutral in
      case (pLeft, pRight) of
           (True,  True)  => OnLeft
           (False, True)  => case searchTree p neutral t neutral of
                                  Just (l, x, r) => Position l x r
                                  Nothing => Nowhere
           (False, False) => OnRight
           (True,  False) => Nowhere

split : MeasureRM a => (Interval -> Bool) -> PosMap a -> (PosMap a, PosMap a)
split p Empty = (Empty, Empty)
split p xs =
  case searchTree (\a, _ => p a) neutral xs neutral of
       Just (l, x, r) => if p (measureTree xs)
                            then (l, x <| r)
                            else (xs, Empty)
       Nothing => (xs, Empty)

(++) : MeasureRM a => PosMap a -> PosMap a -> PosMap a
xs ++ ys = appendTree0 xs ys

export
map : MeasureRM b => (a -> b) -> PosMap a -> PosMap b
map f Empty = Empty
map f (Single x) = Single (f x)
map f (Deep _ pr t sf) = deep (map f pr) (map (map f) t) (map f sf)

export
traverse : (Applicative f, MeasureRM b) => (a -> f b) -> PosMap a -> f (PosMap b)
traverse f Empty = [| Empty |]
traverse f (Single x) = [| Single (f x) |]
traverse f (Deep _ pr t sf) = [| deep (traverse f pr) (traverse (traverse f) t) (traverse f sf) |]

export
takeUntil : MeasureRM a => (Interval -> Bool) -> PosMap a -> PosMap a
takeUntil p = fst . split p

export
dropUntil : MeasureRM a => (Interval -> Bool) -> PosMap a -> PosMap a
dropUntil p = snd . split p

export
Show a => Show (PosMap a) where
  showPrec p xs = showCon p "fromList" $ showArg (foldr (::) [] xs)

larger : FileRange -> Interval -> Bool
larger i (MkInterval (MkRange k _)) = k >= i
larger i NoInterval = False

larger' : FileRange -> Interval -> Bool
larger' i (MkInterval (MkRange k _)) = k > i
larger' i NoInterval = False

||| Inserts a new element in the map, in lexicographical order.
export
insert : Measure a => a -> PosMap a -> PosMap a
insert v m = let (l, r) = split (larger (measure v)) m in l ++ (v <| r)

||| Builds a new map from a list of measurable elements, inserting in
||| lexicographical order.
export
fromList : Measure a => List a -> PosMap a
fromList = foldr insert empty

merge1 : Measure a => PosMap a -> PosMap a -> PosMap a
merge2 : Measure a => PosMap a -> PosMap a -> PosMap a

merge1 xs ys =
  case viewl xs of
       EmptyL => ys
       a <: as' => let (l, r) = split (larger (measure a)) ys in
                       l ++ (a <| assert_total (merge2 as' r))

merge2 xs ys =
  case viewl ys of
       EmptyL => xs
       b <: bs' => let (l, r) = split (larger' (measure b)) xs in
                       l ++ (b <| assert_total (merge1 r bs'))

||| Merges two interval maps.
export
union : Measure a => PosMap a -> PosMap a -> PosMap a
union xs ys = merge1 xs ys

atleast : FilePos -> Interval -> Bool
atleast k (MkInterval (MkRange _ high)) = k <= high
atleast k NoInterval = False

greater : FilePos -> Interval -> Bool
greater k (MkInterval (MkRange low _)) = fst low > k
greater k NoInterval = False

||| Finds all the intervals that overlap with the given interval.
export
inRange : MeasureRM a => FilePos -> FilePos -> PosMap a -> List a
inRange low high t = matches (takeUntil (greater high) t)
  -- takeUntil selects all the intervals within the given upper bound,
  -- however the remaining interval are not necessarily adjacent in
  -- the sequence, thus it drops elements until the next intersecting
  -- interval with dropUntil.
  where matches : PosMap a -> List a
        matches xs = case viewl (dropUntil (atleast low) xs) of
                          EmptyL => []
                          x <: xs' => x :: assert_total (matches xs')

||| Finds the values matching the exact interval input
export
exactRange : MeasureRM a => FilePos -> FilePos -> PosMap a -> List a
exactRange low high t = flip mapMaybe (inRange low high t) $ \ a =>
  do let (MkRange rng _) = measureRM a
     guard (rng == (low, high))
     pure a

||| Returns all the interval that contains the given point.
export
searchPos : MeasureRM a => FilePos -> PosMap a -> List a
searchPos p = inRange p p

||| Returns all the intervals that intersect the given interval.
export
intersections : MeasureRM a => FileRange -> PosMap a -> List a
intersections i = inRange (fst i) (snd i)

||| Returns all the intervals that contain the given interval.
export
dominators : MeasureRM a => FileRange -> PosMap a -> List a
dominators i = inRange (snd i) (fst i)

||| Returns the extreme boundaries of the map, if non empty.
export
bounds : Measure a => PosMap a -> Maybe FileRange
bounds t =
  case measureTree t of
       NoInterval => Nothing
       MkInterval (MkRange _ high) =>
         case viewl t of
              EmptyL => Nothing
              x <: _ => Just (fst (measure x), high)

public export
Measure NonEmptyFC where
  measure = snd

public export
Measure (NonEmptyFC, a) where
  measure = measure . fst


test : Builtin.Equal S (\x : a => S ?)
test = Refl

test2 : ?
test2 = {a : _} -> the (S = \x : a => S _) Refl


-- exercises in "Type-Driven Development with Idris"
-- chapter 5

import System
import Data.Vect

-- check that all functions are total
%default total

--
-- section 5.1
--

printLonger : IO ()
printLonger = do putStr "First string: "
                 str1 <- getLine
                 putStr "Second string: "
                 str2 <- getLine
                 putStrLn $ show (longer str1 str2)
              where
                   longer : String -> String -> Nat
                   longer s1 s2 = max (length s1) (length s2)

printLonger' : IO ()
printLonger' =  putStr "First string: " >>= \_ =>
                getLine >>= \str1 =>
                putStr "Second string: " >>= \_ =>
                getLine >>= \str2 =>
                putStrLn $ show (longer str1 str2)
             where
                  longer : String -> String -> Nat
                  longer s1 s2 = max (length s1) (length s2)

--
-- section 5.2
--

readNumber : IO (Maybe Nat)
readNumber = do
  input <- getLine
  if all isDigit (unpack input)
    then pure (Just (cast input))
    else pure Nothing

partial
guess : (target : Nat) -> (guesses : Nat) -> IO ()
guess target guesses =
  do
    putStr "Enter a number: "
    Just try <- readNumber
  | Nothing => (do putStrLn "wrong number"
                   guess target guesses)
    case compare try target of
          LT => (do putStrLn "too small"
                    guess target (S guesses))
          GT => (do putStrLn "too big"
                    guess target (S guesses))
          EQ => putStrLn ("you win in " ++ show guesses ++ " tries!")

partial
random : Nat -> IO Nat
random k = do raw <- time
              pure $ mod (fromIntegerNat . abs $ raw) k

partial
main : IO ()
main = random 100 >>= (flip guess) 1
-- or:
-- main = do target <- random 100
--           guess target 1

-- can be tested using:
-- > :exec test_repl
-- command: foo
-- 0> foo!
-- command: bar
-- 1> bar!
-- command: quit
-- >
partial
my_replWith : a -> String -> (a -> String -> Maybe (String, a)) -> IO ()
my_replWith state invite f =
  do putStr invite
     input <- getLine
     Just (output, state') <- pure (f state input)
   | Nothing => pure ()
     putStr output
     my_replWith state' invite f

partial
my_repl : String -> (String -> String) -> IO ()
my_repl invite f = my_replWith () invite f'
  where
    f' : a -> String -> Maybe (String, a)
    f' state input = Just (f input, state)

partial
test_repl : IO ()
test_repl = my_replWith 0
                        "command: "
                        (\s,x => if x=="quit"
                                  then Nothing
                                  else Just ((show s) ++ "> " ++ x ++ "!\n", S s))

--
-- section 5.3
--

partial
readToBlank : IO (List String)
readToBlank = do
                line <- getLine
                if line == ""
                  then pure []
                  else (do lines <- readToBlank
                           pure (line :: lines))

partial
run_readToBlank : IO ()
run_readToBlank = do
                    lines <- readToBlank
                    putStrLn $ show lines

-- version that concat lines and write them at once using writeFile
-- (writeFile opens the file in WriteTruncate mode, writes, and then closes the file)
partial
readAndSave : IO ()
readAndSave = do
               putStrLn "Enter lines: "
               lines <- readToBlank
               putStr "Filename: "
               filename <- getLine
               Right () <- writeFile filename (concat $ intersperse "\n" lines)
             | Left error => putStrLn (show error)
               putStrLn $ "lines saved to file " ++ filename

writeLinesToFile : (file : File) ->
                   (lines : List String) ->
                   IO (Either FileError ())
writeLinesToFile file [] = pure (Right ())
writeLinesToFile file (x :: xs)
  = do
      line <- pure (if isNil xs then x else x ++ "\n")
      Right () <- fPutStr file line | Left error => pure (Left error)
      writeLinesToFile file xs

-- version that writes lines one by one
-- (fPutStrLn writes a single line)
partial
readAndSave2 : IO ()
readAndSave2 = do
               putStrLn "Enter lines: "
               lines <- readToBlank
               putStr "Filename: "
               filename <- getLine
               Right file <- openFile filename WriteTruncate
             | Left error => putStrLn (show error)
               Right () <- writeLinesToFile file lines
             | Left error => putStrLn (show error)
               closeFile file
               putStrLn $ "lines saved to file " ++ filename

partial
readVectFileHelper : (file : File) -> IO (Either FileError (n ** Vect n String))
readVectFileHelper file
  = do
      False <- fEOF file | True => pure (Right (_ ** []))
      Right x <- fGetLine file | Left error => pure (Left error)
      Right (m ** xs) <- readVectFileHelper file | Left error => pure (Left error)
      pure $ Right (S m ** x :: xs)

partial
readVectFile : (filename : String) -> IO (n ** Vect n String)
readVectFile filename
  = do
       Right file <- openFile filename Read
     | Left error => (do putStrLn (show error)
                         pure (_ ** []))
       Right dp <- readVectFileHelper file
     | Left error => (do putStrLn (show error)
                         pure (_ ** []))
       closeFile file
       pure dp


module Data.Either.Extras

%default total
%access export

toEither : (input : Bool) -> (left : Lazy l) -> (right : Lazy r) -> Either l r
toEither False left _ = Left left
toEither True _ right = Right right

|||Maps func over l if input is Left l.
mapLeft : (func : Lazy (l -> l')) -> (input : Either l r) -> Either l' r
mapLeft func (Left l) = Left $ func l
mapLeft _ (Right r) = Right r

|||Maps either funcl or funcr over input.
mapEither : (funcl : Lazy (l -> l')) -> (funcr : Lazy (r -> r')) -> (input : Either l r) -> Either l' r'
mapEither funcl _ (Left l) = Left $ funcl l
mapEither _ funcr (Right r) = Right $ funcr r


module Text.CSS.Length

import Text.CSS.Render

%default total

public export
data Length : Type where
  Pt       : Bits16 -> Length
  Px       : Bits16 -> Length
  Em       : Double -> Length
  Rem      : Double -> Length

export
Render Length where
  render (Pt x)   = show x ++ "pt"
  render (Px x)   = show x ++ "px"
  render (Em x)   = show x ++ "em"
  render (Rem x)  = show x ++ "rem"

export %inline
pt : Cast Length a => Bits16 -> a
pt = cast . Pt

export %inline
px : Cast Length a => Bits16 -> a
px = cast . Px

export %inline
em : Cast Length a => Double -> a
em = cast . Em

export %inline
rem : Cast Length a => Double -> a
rem = cast . Rem


||| TODO docs
module RegExp.String

import Decidable.Equality
import RegExp as RE
import public RegExp.Types as RET

infixr 2 .|.
infixr 3 .&.
infixr 5 .+.
infixr 6 ...

-----------
-- TYPES --
-----------

||| A regular expression specification.
public export
RegExp : Type
RegExp = RET.RegExp Char

||| The property of a regular expression matching an input string.
public export
Matches : RegExp -> String -> Type
Matches r s = RET.Matches r (unpack s)

---------------
-- OPERATORS --
---------------

||| Builds a `RegExp` matching a single character.
export
lit : Char -> RegExp
lit = Lit

||| Builds a `RegExp` as the concatenation of two other `RegExp`.
export
(.+.) : RegExp -> RegExp -> RegExp
(.+.) = Cat

||| Builds a `RegExp` as the disjunction of two other `RegExp`.
export
(.|.) : RegExp -> RegExp -> RegExp
(.|.) = Disj

||| Builds a `RegExp` as the conjunction of two other `RegExp`.
export
(.&.) : RegExp -> RegExp -> RegExp
(.&.) = Conj

||| Builds a `RegExp` which optionally matches another `RegExp`.
export
one : RegExp -> RegExp
one r = Star r .|. Empty

||| Builds a `RegExp` which matches zero or more of another `RegExp`.
export
star : RegExp -> RegExp
star = Star

||| Builds a `RegExp` which matches one or more of another `RegExp`.
export
plus : RegExp -> RegExp
plus r = Cat r $ Star r

||| Builds a `RegExp` which matches a range of characters.
export
(...) : Char -> Char -> RegExp
(...) x y = let x' = min x y
                y' = max x y in
                to (ord x') ((ord y') - 1) (Lit y') where
  to : Int -> Int -> RegExp -> RegExp
  to min n r = if n < min
               then r
               else to min (n - 1) (Disj (Lit (chr n)) r)

||| Builds a `RegExp` which matches any one of the provided characters.
export
any : (Foldable a, Functor a) => (xs : a Char) -> RegExp
any = foldr (.|.) Null . map Lit

----------------
-- SHORTHANDS --
----------------

||| Matches a lowercase ASCII character.
export
lowercase : RegExp
lowercase = 'a'...'z'

||| Matches an uppercase ASCII character.
export
uppercase : RegExp
uppercase = 'A'...'Z'

||| Matches an alphabetical ASCII character.
export
alpha : RegExp
alpha = lowercase .|. uppercase

||| Matches a numeric digit ASCII character.
export
digit : RegExp
digit = '0'...'9'

||| Matches an alphanumeric ASCII character.
export
alphaNumeric : RegExp
alphaNumeric = alpha .|. digit

||| Matches an alphanumeric or underscore ASCII character.
export
word : RegExp
word = alphaNumeric .|. lit '_'

||| Matches a whitespace ASCII character.
export
whitespace : RegExp
whitespace = any [' ', '\t', '\r', '\n', '\v', '\f']

--------------
-- MATCHING --
--------------

||| Decides whether the provided string matches a regular expression.
export
matches : (r : RegExp) -> (s : String) -> Dec (Matches r s)
matches r s = RE.matches r (unpack s)

-----------
-- TESTS --
-----------

test_range_single : 'x'...'x' = Lit 'x'
test_range_single = Refl

test_to_asc : 'a'...'c' = (Disj (Lit 'a') (Disj (Lit 'b') (Lit 'c')))
test_to_asc = Refl

test_to_desc : '3'...'1' = (Disj (Lit '1') (Disj (Lit '2') (Lit '3')))
test_to_desc = Refl


module Brainfeck.Instructions

import Data.Vect as V

import Brainfeck.Type

-- TODO: Implement this at some point

%default total

-- TODO: Possibly mae index : Fin n, so its always bounded by the length of instrutions.
-- How to encode that in the constructor?
data Instructions : (index : Nat) -> Vect n Token -> Type where
  Ins : (prev : Vect index Token) -> (remaining : Vect rLen Token) -> Instructions (V.length prev) (reverse prev ++ remaining)

%name Instructions instructions

instructions : (is : Vect n Token) -> Instructions 0 is
instructions is = Ins [] is

current : {auto p: LT pc (V.length is) } -> Instructions pc is -> Token
-- current (Ins prev (cur :: is)) = cur

step : {auto p : LT pc (V.length is)} -> Instructions pc is -> Instructions (S pc) is
-- step (Ins prev (cur :: rem)) = ?stepPrf $ Ins (cur :: prev) rem

jump : (next : Nat) -> Instructions pc is -> Instructions next is


module NanoParsec.MonadPlus

export
interface (Monad m) => MonadPlus (m : Type -> Type) where
    mzero : m a
    mplus : m a -> m a -> m a


module Debug.Buffer

import Data.Buffer
import Data.List
import Data.String.Extra

toHex : Int -> Int -> String
toHex d n = pack $ reverse $ foldl toHexDigit [] (slice d n [])
    where
        toHexDigit : List Char ->Int -> List Char
        toHexDigit acc i = chr (if i < 10 then i + ord '0' else (i-10) + ord 'A')::acc
        slice : Int -> Int -> List Int -> List Int
        slice 0 _ acc = acc
        slice d n acc = slice (d-1) (n `div` 16) ((n `mod` 16)::acc)

showSep : String -> Nat -> List String -> String
showSep sep _ [] = ""
showSep sep n [x] = x ++ replicate (3*n) ' '
showSep sep Z (x :: xs) = x ++ sep ++ showSep sep Z xs
showSep sep (S n) (x :: xs) = x ++ sep ++ showSep sep n xs

renderRow : List Int -> String
renderRow dat =  showSep " " 16 (map (toHex 2) dat) ++
                "      " ++ pack (map (\i => if i > 0x1f && i < 0x80 then chr i else '.') dat)

group : Nat -> List a -> List (List a)
group n xs = worker [] xs
    where
        worker : List (List a) -> List a -> List (List a)
        worker acc [] = reverse acc
        worker acc ys = worker ((take n ys)::acc) (drop n ys)

export
dumpBuffer : HasIO io => Buffer -> io String
dumpBuffer buf = do
    size <- liftIO $ rawSize buf
    dat <- liftIO $ bufferData buf
    let rows = group 16 dat
    let hex = showSep "\n" 0 (map renderRow rows)
    pure $ hex ++ "\n\ntotal size = " ++ show size

export
printBuffer : HasIO io => Buffer -> io ()
printBuffer buf = putStrLn $ !(dumpBuffer buf)


-- ---------------------------------------------------------------- [ Dict.idr ]
-- Module    : Dict.idr
-- Copyright : (c) 2015,2016 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| A Dictionary based upon an AVL Key-Value AVL.API.
module Data.AVL.API.Dict

import Data.AVL

%default total
%access export

data Dict : (k : Type) -> Type -> Type where
  MkDict : AVLTree h k v -> Dict k v

||| Empty
empty : (Ord k) => Dict k v
empty = MkDict (Element Empty AVLEmpty)

insert : (Ord k) => k -> v -> Dict k v -> Dict k v
insert key val (MkDict d) = MkDict $ snd (AVL.API.insert key val d)

||| Update the value for the given key.
update : (Ord k) => k -> (v -> v) -> Dict k v -> Dict k v
update x ufunc (MkDict d) = MkDict $ AVL.API.update x ufunc d

-- -------------------------------------------------------------------- [ List ]

toList : Dict k v -> List (k,v)
toList (MkDict d) = AVL.API.toList d

fromList : Ord k => List (k,v) -> Dict k v
fromList kvs = MkDict $ snd $ AVL.API.fromList kvs

-- ----------------------------------------------------------------- [ Queries ]

isEmpty : Dict k v -> Bool
isEmpty (MkDict d) = AVL.API.isEmpty d

foldr : (k -> v -> p -> p) -> p -> Dict k v -> p
foldr f init (MkDict d) = AVL.API.foldr f init d

lookup : (Ord k) => k -> Dict k v -> Maybe v
lookup k (MkDict d) = AVL.API.lookup k d

keys : Dict k v -> List k
keys (MkDict d) = AVL.API.keys d

values : Dict k v -> List v
values (MkDict d) = AVL.API.values d

size : Dict k v -> Nat
size (MkDict d) = AVL.API.size d

hasKey : (Ord k) => k -> Dict k v -> Bool
hasKey key (MkDict d) = AVL.API.hasKey key d

hasValue : (Eq v) => v -> Dict k v -> Bool
hasValue val (MkDict d) = AVL.API.hasValue val d

hasValueUsing : (v -> Bool) -> Dict k v -> Bool
hasValueUsing f (MkDict d) = AVL.API.any (\k,v => (f v)) d

findKey : (pred : v -> Bool) -> Dict k v -> Maybe k
findKey pred (MkDict d) = AVL.API.findKey pred d

findKeyOf : (Eq v) => v -> Dict k v -> Maybe k
findKeyOf v (MkDict d) = AVL.API.findKeyOf v d

-- --------------------------------------------------------- [ Implementations ]

(Eq k, Eq v) => Eq (Dict k v) where
   (==) (MkDict {h = h} x) (MkDict {h = h'} y) with (decEq h h')
     (==) (MkDict {h = h} x) (MkDict {h = h} y)  | Yes Refl = x == y
     (==) (MkDict {h = h} x) (MkDict {h = h'} y) | No _     = False

(Show k, Show v) => Show (Dict k v) where
  show (MkDict d) = show d

Ord a => Functor (Dict a) where
  map func x = fromList $ (\(a, b) => (a, func b)) <$> toList x

Ord a => Foldable (Dict a) where
  foldr func = foldr $ const func

Ord a => Traversable (Dict a) where
  traverse f x = fromList <$> (traverse (\(a, b) => (MkPair a) <$> f b) $ Data.AVL.API.Dict.toList x)

namespace Predicates

  export
  data HasKey : (key  : typeKey)
             -> (dict : Dict typeKey typeValue)
             -> Type
    where
      IsKey : (prf : HasKey key tree)
           -> HasKey key (MkDict tree)

  private
  keyNotInDict : (contra : HasKey key tree -> Void)
              -> HasKey key (MkDict tree)
              -> Void
  keyNotInDict contra (IsKey x) = contra x

  isKey : DecEq typeKey
       => (key  : typeKey)
       -> (dict : Dict typeKey typeValue)
       -> Dec (HasKey key dict)
  isKey key (MkDict tree) with (isKey key tree)
    isKey key (MkDict tree) | (Yes x) = Yes (IsKey x)
    isKey key (MkDict tree) | (No contra) = No (keyNotInDict contra)

  export
  data HasValue : (value : typeValue)
               -> (dict  : Dict typeKey typeValue)
               -> Type
    where
      IsValue : (prf : HasValue value tree)
             -> HasValue value (MkDict tree)

  private
  valueNotInDict : (contra : HasValue value tree -> Void)
                -> HasValue value (MkDict tree)
                -> Void
  valueNotInDict contra (IsValue prf) = contra prf

  isValue : DecEq typeValue
         => (value : typeValue)
         -> (dict  : Dict typeKey typeValue)
         -> Dec (HasValue value dict)
  isValue value (MkDict tree) with (isValue value tree)
    isValue value (MkDict tree) | (Yes x) = Yes (IsValue x)
    isValue value (MkDict tree) | (No contra) = No (valueNotInDict contra)

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


module counts

export
counts : String -> (Nat, Nat)
counts str =
    let nwords = length (words str)
        nchars = length str in
            (nwords, nchars)


module Gspider.Core

import Types.RestrictedCharString

%access private

||| Represents a system as a list of supported password characters.
public export
System : Type -- System is a type alias for a character list.
System = List Char

||| Represents a password probability distribution for a system.
|||
||| @s the system
public export
Distribution : (s : System) -> Type
Distribution s = (RestrictedCharString s) -> Double


module X

public export
data Ty : Type where
  A : Ty
  B : Ty

public export
f : (d : Ty) => Nat -> Ty
f _ = d

g : f 0 = B
g = Refl


module Vectors

import Data.Vect

%default total

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

sixInts : Vect 6 Int
sixInts = [5, 6, 7, 8, 9, 10]

tenInts : Vect 10 Int
tenInts = fourInts ++ sixInts

allLengths : Vect len String -> Vect len Nat
allLengths [] = []
allLengths (x :: xs) = length x :: allLengths xs


module Test

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

                  x * x + y * y == z * z ]

namespace Inside
  -- Needs to be recursive (or at least refer to a name in this module)
  -- to check that definitions are updated on import...as
  export
  fact : Nat -> Nat
  fact Z = 1
  fact (S k) = (S k) * fact k

public export
interface Needle a where
  nardle : a -> a
  noo : a -> a


module Data.Fuel

%default total

||| Fuel for running total operations potentially indefinitely.
public export
data Fuel = Dry | More (Lazy Fuel)

||| Provide `n` units of fuel.
export
limit : Nat -> Fuel
limit  Z    = Dry
limit (S n) = More (limit n)

||| Provide fuel indefinitely.
||| This function is fundamentally partial.
partial
export
forever : Fuel
forever = More forever


module Main

import IdrisJvm.FFI
import IdrisJvm.IO

-- Returning an additional Nat to test that `par` returns a complex type correctly
fibonacci : Integer -> (Nat, Integer)
fibonacci 0 = (0, 0)
fibonacci 1 = (1, 1)
fibonacci n =
  let (fibNat1, fib1) = par $ fibonacci (n - 1) -- Evaluate in parallel using Java's ForkJoin
      (fibNat2, fib2) = par $ fibonacci (n - 2) -- Evaluate in parallel
      fibNat = fibNat1 + fibNat2
  in (fibNat * 2, fib1 + fib2)

shutdownExecutor : JVM_IO ()
shutdownExecutor = javacall (Static clz "shutdownExecutor") (JVM_IO ()) where
  clz = Class "io/github/mmhelloworld/idrisjvm/runtime/Concurrent"

main : JVM_IO ()
main = do
  fork $ printLn "a" -- Run in a new thread using Java's ExecutorService
  fork $ printLn "b" -- Run in another thread
  fork $ printLn $ fibonacci 10
  fork $ printLn "cde"
  fork $ printLn "fg"
  printLn "h"
  shutdownExecutor


module Control.Monad.State.Tuple

import public Control.Monad.State

%default total

export
Monad m => MonadState l (StateT (l, r) m) where
  get = Builtin.fst <$> get
  put = modify . mapFst . const

wrapFst : Functor m => StateT r m a -> StateT (l, r) m a
wrapFst act = ST $ \(x, y) => mapFst (x,) <$> runStateT y act

export
MonadState s (StateT r m) => Monad m => MonadState s (StateT (l, r) m) where
  get = wrapFst get
  put = wrapFst . put


module Quantities.SIBaseUnits

import Quantities.Core
import Quantities.SIPrefixes
import Quantities.SIBaseQuantities

%default total
%access public export

Metre : ElemUnit Length
Metre = MkElemUnit "m" 1
Meter : ElemUnit Length
Meter = Metre
M : ElemUnit Length
M = Meter

Centimetre : Unit Length
Centimetre = centi Metre
Centimeter : Unit Length
Centimeter = Centimetre
Cm : Unit Length
Cm = Centimetre

Kilometre : Unit Length
Kilometre = kilo Metre
Kilometer : Unit Length
Kilometer = Kilometre
Km : Unit Length
Km = Kilometre

Gram : ElemUnit Mass
Gram = MkElemUnit "g" 0.001
G : ElemUnit Mass
G = Gram

Kilogram : Unit Mass
Kilogram = kilo Gram
Kg : Unit Mass
Kg = Kilogram

Second : ElemUnit Time
Second = MkElemUnit "s" 1
S : ElemUnit Time
S = Second

Ampere : ElemUnit ElectricCurrent
Ampere = MkElemUnit "A" 1
A : ElemUnit ElectricCurrent
A = Ampere

Kelvin : ElemUnit Temperature
Kelvin = MkElemUnit "K" 1
K : ElemUnit Temperature
K = Kelvin

Mole : ElemUnit AmountOfSubstance
Mole = MkElemUnit "mol" 1
Mol : ElemUnit AmountOfSubstance
Mol = Mole

Candela : ElemUnit LuminousIntensity
Candela = MkElemUnit "cd" 1
Cd : ElemUnit LuminousIntensity
Cd = Candela


module AutoSearchHide2

import AutoSearchHide1

myZero : Value === 0
myZero = Refl

[OneA] A where
  Value = 1

%hint
HintOneA : A
HintOneA = OneA

-- Want to use the OneA (via HintOneA) instance here.

-- `%hide` should block the auto-search from
-- including the `HintZeroA` hint into the list of solutions.
-- Thus, we don't get into the `multiple solutions` situation.
%hide HintZeroA
myOne : Value === 1
myOne = Refl


module Vehicle

%default total

data PowerSource = Petrol | Pedal

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

wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels (Car fuel) = 4
wheels (Bus fuel) = 4

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car _) = Car 50
refuel (Bus _) = Bus 100
refuel Bicycle impossible


record Nat2 where
  nat : Nat

f : Nat2 -> Nat2
f = { nat $= floor }


module Ipkg.Types

import Data.List1

public export
data PkgVersion = PV (List1 Nat)

public export
record PkgVersionBounds where
  constructor PVB
  lowerBound : Maybe PkgVersion
  lowerInclusive : Bool
  upperBound : Maybe PkgVersion
  upperInclusive : Bool

export
anyBounds : PkgVersionBounds
anyBounds = PVB Nothing True Nothing True

public export
record Depends where
  constructor D
  name : String
  bounds : PkgVersionBounds

public export
record Package where
  constructor P
  name : String
  version : Maybe PkgVersion
  strFields : List (String, String)
  depends : List Depends
  modules : List String

export
def : String -> Package
def s = P s Nothing [] [] []

public export
Show PkgVersion where
  show (PV v) = foldl1By (\acc, next => "\{acc}.\{show next}") show v

public export
Show Depends where
  show (D n b) = n

public export
Show Package where
  show (P n v s d m) =
    "package \{n}\n" ++
    (maybe "" (\x => "version \{show x}\n") v) ++
    "modules: \{show m}\n" ++
    "depends: \{show d}\n" ++
    "strings:\n" ++ show s ++ "\n"


module DecEqTest

import Language.Elab.Deriving.DecEq
import Decidable.Equality

%language ElabReflection

data Flippy = Dolphin | Shark

%runElab deriveDecEq Export  `{{Flippy}}

export
data Foo1 : Type -> Type where
  Bor1 : Foo1 a

export
data Foo2 : Type -> Type where
  Bor2 : a -> Foo2 a

data Foo4 : Type -> Type -> Type where
  Bor4 : b -> Foo4 a b

data Foo5 : Type -> Type -> Type -> Type where
  Bor5 : a -> b -> c -> Foo5 a b c

-- NB c is never used, so Eq shouldn't be required for it
data Foo7 : Type -> Type -> Type -> Type where
  Zor7 : a -> Foo7 a b c
  Gor7 : b -> Foo7 a b c
  Nor7A : a -> b -> Foo7 a b c
  Nor7B : a -> b -> c -> Foo7 a b c
  Bor7 : Foo7 a b c

-- NB a is never used, so Eq shouldn't be required for it
data Foo7' : Type -> Type -> Type -> Type where
  Zor7' : c -> Foo7' a b c
  Gor7' : b -> Foo7' a b c
  Nor7' : b -> c -> Foo7' a b c
  Bor7' : Foo7' a b c

  -- we'll use our own nat for index experimentation
export
data MyNat : Type where
  MZ : MyNat
  MS : MyNat -> MyNat

data Foo6 : Type -> Type -> Type -> Nat -> Type where
  Zor6 : a -> b -> Foo6 a b c Z
  Gor6 : b -> Foo6 a b c (S k)
  Nor6A : a -> b -> c -> Foo6 a b c n
  -- Nor6B : a -> (0 _ : b) -> c -> Foo6 a b c n -- NB: 0 Use arg
  Bor6A : Foo6 a b c n
  Bor6B : Foo6 a b c n -> Foo6 a b c n
  Wah6 : a -> (n : Nat) -> Foo6 a b c n

export
data Foo6' : Type -> Type -> Type -> MyNat -> Type where
  Zor6'  : a -> b -> Foo6' a b c MZ
  Gor6A'  : b -> Foo6' a b c (MS k)
  Gor6B'  : (k : MyNat) -> b -> Foo6' a b c (MS k)
  Nor6A' : a -> b -> c -> Foo6' a b c n
  -- Nor6B' : a -> (0 _ : b) -> c -> Foo6' a b c n
  Bor6'  : Foo6' a b c n
  Wah6'  : a -> (n : MyNat) -> Foo6' a b c n
  -- Kah6'  : a -> (n : MyNat) -> (0 _ : c) -> Foo6' a b c n
  -- Pah6'  : a -> (n : MyNat) -> MyNat -> (0 _ : c) -> Foo6' a b c n
  -- Rah6'  : a -> (n : MyNat) -> Foo6' a b c n -> MyNat -> (0 _ : c) -> Foo6' a b c n -> Foo6' a b c n
  -- Gah6'  : {1 _ : a} -> (n : MyNat) -> MyNat -> (0 _ : c) -> Foo6' a b c n
  -- ^ another case to consider, what if I'm implicit but M1?
  -- Seems like an error would be appropriate there rather than showing
  -- implicits. Though showing implicits could be a flag in instance generation
  -- I guess.

-- eqImplFoo6'Fun (Wah6' 'c' MZ) (Wah6' 'c' MZ)
-- eqImplFoo6'Fun (Nor6A' {n=MZ} 'c' 'd' 'e')

-- eqImplFoo6Fun (Wah6 {b=Int} {c=String} 'c' (S Z)) (Wah6 'c' (S Z))

data FooN : MyNat -> Type -> Type where
  BorZ : b -> FooN MZ b
  BorS : b -> FooN (MS MZ) b
  BorNA : (k : MyNat) -> b -> FooN n b
  BorNB : (n : MyNat) -> b -> FooN n b

data XXX : Type where
  MkXXX : {a : Int} -> (b : Int) -> XXX

%runElab deriveDecEq Export  `{{MyNat}}
%runElab deriveDecEq Export `{{Foo1}}
%runElab deriveDecEq Export  `{{Foo2}}
%runElab deriveDecEq Private `{{Foo4}}
%runElab deriveDecEq Private `{{Foo5}}
%runElab deriveDecEq Private `{{Foo7}}
%runElab deriveDecEq Private `{{Foo7'}}
-- %runElab deriveDecEq Private `{{FooN}}
-- %runElab deriveDecEq Private `{{Foo6}}
-- %runElab deriveDecEq Export  `{{Foo6'}}
%runElab deriveDecEq Export  `{{XXX}}

-- can check what's generated via
-- :printdef eqImplFoo7'Fun


data Foo : Type where
  |||An A
  A ,
  ||| Just a B
  B : Foo

public export
foo1, foo2 : Foo
foo1 = A
foo2 = LocalB
  where
    LocalB, LocalA : Foo
    LocalB = B
    LocalA = let NestedLocalA, NestedLocalB : Foo
                 NestedLocalA = A
                 NestedLocalB = B
             in NestedLocalA


module WebAssembly.Validation.Modules.StartFunction

import WebAssembly.Structure
import WebAssembly.Validation.Conventions
import WebAssembly.Validation.Types

||| [🔗 Spec](https://webassembly.github.io/spec/core/valid/modules.html#start-function)
|||
||| ```
||| C.funcs[x] = [] -> []
||| ---------------------
||| C ⊢ {func x} ok
||| ```
public export
data ValidStart : Context -> Start -> Type where
  MkValidStart : (c : Context)
              -> (x : FuncIdx)
              -> {auto in_bounds: InBounds x (funcs c)}
              -> (index x (funcs c) = ([] ->> []))
              -> ValidStart c (MkStart x)


||| mutable array
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Data.Container.Mutable.RingQueue

import Data.Container.Mutable.Array

import Data.Nat
import Data.IORef
import Data.Fin
import Data.So

%default total

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

export
record IORingQueue t where
  constructor MkIORingQueue
  content : IOArray (Maybe t)
  loc : IORef (Nat, Nat)

export newIORingQueue : HasIO io
  => (cap:Nat) -> {auto 0 capacity_isnt_zer: So (cap /= 0)}
  -> io (IORingQueue t)
newIORingQueue cap@(S c) = pure $ MkIORingQueue !(newIOArray cap Nothing) !(newIORef (0, 0))

export null : HasIO io => IORingQueue a -> io Bool
null q = readIORef q.loc >>= pure . (0 ==) . snd

export length : HasIO io => IORingQueue a -> io Nat
length q = readIORef q.loc >>= pure . snd

export push : HasIO io => a -> IORingQueue a -> io Bool
push x q = do
  (n, m) <- readIORef q.loc
  if m >= capacity q.content
     then pure False
     else do
       writeIOArray q.content (restrict q.content (cast $ n + m)) (Just x)
       writeIORef q.loc (n, m + 1)
       pure True

export pull : HasIO io => IORingQueue a -> io (Maybe a)
pull q = do
  (n, (S m)) <- readIORef q.loc
   | (_, Z) => pure Nothing
  writeIORef q.loc ((n + 1) `mod` (capacity q.content), m)
  let i = restrict q.content $ cast n
  r <- readIOArray q.content i
  writeIOArray q.content i Nothing
  pure r

{-
export
HasIO io => MutableQueue io IORingQueue where
    null q = readIORef q.loc >>= pure . (0 ==) . snd
    length q = readIORef q.loc >>= pure . snd

    push x q = do
      (n, m) <- readIORef q.loc
      if m >= capacity q.content
         then pure False
         else do
           writeIOArray q.content (restrict q.content (cast $ n + m)) (Just x)
           writeIORef q.loc (n, m + 1)
           pure True

    pull q = do
      (n, (S m)) <- readIORef q.loc
        | (_, Z) => pure Nothing
      writeIORef q.loc ((n + 1) `mod` (capacity q.content), m)
      let i = restrict q.content $ cast n
      r <- readIOArray q.content i
      writeIOArray q.content i Nothing
      pure r

-}

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


module Control.Effect.Lift

import Control.EffectAlgebra

namespace Algebra
  public export
  [Lift] Monad m => Algebra (Lift m) m where
    alg ctxx hdl (MkLift x) = x >>= hdl . ( <$ ctxx)

  %hint public export
  HintLift : Monad m => Algebra (Lift m) m
  HintLift = Lift

||| Lift a computation to the underlying effect stack.
public export
lift : Monad n => Inj (Lift n) sig => Algebra sig m => n a -> m a
lift x = send {eff = Lift n} $ MkLift (map pure x)


module Data.Prim.String

import public Data.DPair
import public Data.Prim.Ord

%default total

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

||| Lower bound of `String`
public export
MinString : String
MinString = ""

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

||| Not value of type `String` is less than `MinString`.
export
0 Not_LT_MinString : m < MinString -> Void
Not_LT_MinString = GTE_not_LT (GTE_MinString m)


module Cordial.Model.Common.WireTy

import Data.Ranged

import Cordial.Model.Common.Essential

%default total
%access public export

||| Type of wire.
data WireTy : Type where
   ||| Does the wire carry memory mapable data or addresses
   Data : Bool -> WireTy

   ||| Clock for the interface
   Clock : (edge  : Maybe ClockEdge)
        -> (delay : Maybe Delay)
        -> (phase : Maybe (RangedNat 0 100))
        -> WireTy

   Reset : WireTy

   Information : WireTy
   Interrupt : WireTy
   Control   : WireTy
   General   : WireTy

DataWire : WireTy
DataWire = Data False

AddressWire : WireTy
AddressWire = Data True


-- TypeFuns.idr

-- Demonstrates type functions to calculate stuff for either an int or string

StringOrInt : Bool -> Type
StringOrInt False = String
StringOrInt True = Int

||| Returns a String or Int literal, depending on the input
||| parameter.
getStringOrInt : (isInt : Bool) -> StringOrInt isInt
getStringOrInt False = "Ninety four"
getStringOrInt True = 94

||| Converts the given StringOrInt to a (trimmed) String
valToString : (isInt : Bool) -> StringOrInt isInt -> String
valToString False y = trim y
valToString True y = cast y

||| Converts the given StringOrInt to a (trimmed) String
||| Alternative implementation using a case construct
||| in the type signature
valToString2 : (isInt : Bool) -> (case isInt of
                                       False => String
                                       True => Int) -> String
valToString2 False y = trim y
valToString2 True y = cast y


module Data.SOP.SOP

import Data.List.Elem

import Data.SOP.NP
import Data.SOP.NS
import Data.SOP.POP
import Data.SOP.Utils
import Data.SOP.Interfaces
import Data.Maybe

import Decidable.Equality

%default total

||| A sum of products.
|||
||| The elements of the (inner) products
||| are applications of the parameter f. The type SOP_ is indexed by the list of
||| lists that determines the sizes of both the (outer) sum and all the (inner)
||| products, as well as the types of all the elements of the inner products.
|||
||| A SOP I reflects the structure of a normal Idris datatype. The sum structure
||| represents the choice between the different constructors, the product structure
||| represents the arguments of each constructor.
public export
data SOP_ : (k : Type) -> (f : k -> Type) -> (kss : List $ List k) -> Type where
  MkSOP : NS_ (List k) (NP_ k f) kss -> SOP_ k f kss

||| Type alias for `SOP_` with type parameter `k` being
||| implicit. This reflects the kind-polymorphic data type
||| in Haskell.
public export
SOP : {k : Type} -> (f : k -> Type) -> (kss : List (List k)) -> Type
SOP = SOP_ k

public export %inline
unSOP : SOP_ k f kss -> NS_ (List k) (NP_ k f) kss
unSOP (MkSOP ns) = ns

--------------------------------------------------------------------------------
--          Specialized Interface Functions
--------------------------------------------------------------------------------

||| Specialiced version of `hmap`
public export
mapSOP : (fun : forall a . f a -> g a) -> SOP f kss -> SOP g kss
mapSOP fun = MkSOP . mapNS (\p => mapNP fun p) . unSOP

||| Specialization of `hap`
public export
hapSOP : POP (\a => f a -> g a) kss -> SOP f kss -> SOP g kss
hapSOP (MkPOP fs) = MkSOP . hliftA2 (\p => hapNP p) fs . unSOP

||| Specialization of `hfoldl`
public export
foldlSOP : (fun : acc -> el -> acc) -> acc -> SOP (K el) kss -> acc
foldlSOP fun acc (MkSOP $ Z vs) = foldlNP fun acc vs
foldlSOP fun acc (MkSOP $ S x)  = foldlSOP fun acc (MkSOP x)

||| Specialization of `hfoldr`
public export %inline
foldrSOP : (fun : el -> Lazy acc -> acc) -> Lazy acc -> SOP (K el) kss -> acc
foldrSOP fun acc (MkSOP $ Z vs) = foldrNP fun acc vs
foldrSOP fun acc (MkSOP $ S x)  = foldrSOP fun acc (MkSOP x)

||| Specialization of `hsequence`
public export
sequenceSOP : Applicative g => SOP (\a => g (f a)) kss -> g (SOP f kss)
sequenceSOP = map MkSOP . sequenceNS . mapNS (\p => sequenceNP p) . unSOP

||| Specialization of `hcollapse`
public export
collapseSOP : SOP (K a) kss -> List a
collapseSOP = collapseNS . mapNS (\v => collapseNP v) . unSOP

--------------------------------------------------------------------------------
--          Injections
--------------------------------------------------------------------------------

||| An injection into an n-ary sum of products takes an n-ary product of
||| the correct type and wraps it in one of the sum's possible choices.
public export
0 InjectionSOP : (f : k -> Type) -> (kss : List $ List k) -> (vs : List k) -> Type
InjectionSOP f kss vs = NP f vs -> K (SOP f kss) vs

||| The set of injections into an n-ary sum `NS f ks` can
||| be wrapped in a corresponding n-ary product.
public export
injectionsSOP : {kss : _} -> NP_ (List k) (InjectionSOP f kss) kss
injectionsSOP = hmap (MkSOP .) $ injections {ks = kss}

||| Applies all injections to a product of products of values.
|||
||| This is not implemented in terms of `injectionsSOP` for the
||| following reason: Since we have access to the structure
||| of the product of products and thus `kss`, we do not need a
||| runtime reference of `kss`. Therefore, when applying
||| injections to a product of products, prefer this function
||| over a combination involving `injectionsSOP`.
public export
apInjsPOP_ : POP f kss -> NP (K $ SOP f kss) kss
apInjsPOP_  = mapNP (\ns => MkSOP ns) . apInjsNP_ . unPOP

||| Alias for `collapseNP . apInjsPOP_`
public export
apInjsPOP : POP f kss -> List (SOP f kss)
apInjsPOP = collapseNP . apInjsPOP_

||| Injects a product into an n-ary sum of products.
public export
injectSOP : {0 ks : List k} -> (v : NP f ks) -> {auto prf : Elem ks kss} -> SOP f kss
injectSOP v = MkSOP $ inject v

||| Tries to extract a product of the given type from an
||| n-ary sum of products.
public export
extractSOP :  (0 ks : List k)
           -> SOP f kss
           -> {auto prf : Elem ks kss}
           -> Maybe (NP f ks)
extractSOP ks (MkSOP ns) = extract ks {prf} ns

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

public export %inline
HFunctor k (List $ List k) (SOP_ k) where hmap = mapSOP

public export %inline
HAp k (List $ List k) (POP_ k) (SOP_ k) where hap = hapSOP

public export %inline
HFold k (List $ List k) (SOP_ k) where
  hfoldl = foldlSOP
  hfoldr = foldrSOP

public export
HSequence k (List $ List k) (SOP_ k) where hsequence = sequenceSOP

public export %inline
HCollapse k (List $ List k) (SOP_ k) List where hcollapse = collapseSOP

public export
POP (Eq . f) kss => Eq (SOP_ k f kss) where
  MkSOP a == MkSOP b = a == b

public export
POP (Ord . f) kss => Ord (SOP_ k f kss) where
  compare (MkSOP a) (MkSOP b) = compare a b

public export
POP (Show . f) kss => Show (SOP_ k f kss) where
  showPrec p (MkSOP ns) = showCon p "MkSOP" (showArg ns)

||| Sums of products have instances of `Semigroup` and `Monoid`
||| only when they consist of a single choice, which must itself be
||| a `Semigroup` or `Monoid`.
public export
POP (Semigroup . f) [ks] => Semigroup (SOP_ k f [ks]) where
  MkSOP a <+> MkSOP b = MkSOP $ a <+> b

||| Sums of products have instances of `Semigroup` and `Monoid`
||| only when they consist of a single choice, which must itself be
||| a `Semigroup` or `Monoid`.
public export
POP (Monoid . f) [ks] => Monoid (SOP_ k f [ks]) where
  neutral = MkSOP neutral

private
mkSOPInjective : MkSOP a = MkSOP b -> a = b
mkSOPInjective Refl = Refl

public export
POP (DecEq . f) kss => DecEq (SOP_ k f kss) where
  decEq (MkSOP a) (MkSOP b) with (decEq a b)
    decEq (MkSOP a) (MkSOP a) | Yes Refl   = Yes $ cong MkSOP Refl
    decEq (MkSOP a) (MkSOP b) | No  contra = No (contra . mkSOPInjective)

--------------------------------------------------------------------------------
--          Examples and Tests
--------------------------------------------------------------------------------

neutralTest : SOP I [[String, Maybe Int],[()]]
neutralTest = hcpure Monoid neutral

hapTest : SOP Maybe [[String,Int]] -> SOP I [[String,Int]]
hapTest = hap (MkPOP $ [[fromMaybe "foo", const 12]])


||| Interfaces of basic containers.
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Data.Container.Interfaces

import Data.Maybe

%default total

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

namespace Immutable

  public export
  interface Container a where
    0 KeyTy : Type
    null     : a -> Bool
    count    : a -> Nat
    contains : KeyTy -> a -> Bool
    delete   : KeyTy -> a -> a

  namespace Set
    public export
    interface Container a => Set a where
      0 KeyTy : Type
      insert   : KeyTy -> a -> a

  namespace Map
    public export
    interface Container a => Map a where
      0 KeyTy : Type
      0 ValTy : Type
      lookup   : KeyTy -> a -> Maybe ValTy
      insert   : KeyTy -> ValTy -> a -> a

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

namespace Mutable

  public export
  interface MutableContainer m a where
    0 KeyTy : Type
    null     : a -> m Bool
    count    : a -> m Nat
    contains : KeyTy -> a -> m Bool
    delete   : KeyTy -> a -> m ()

  namespace Set
    public export
    interface MutableContainer m a => MutableSet m a where
      0 KeyTy : Type
      insert   : KeyTy -> a -> m ()

  namespace Map
    public export
    interface MutableContainer m a => MutableMap m a where
      0 KeyTy : Type
      0 ValTy : Type
      lookup   : KeyTy -> a -> m (Maybe ValTy)
      insert   : KeyTy -> ValTy -> a -> m ()

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


{--
Copyright 2021 Joel Berkeley

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
--}
||| This module contains definitions and utilities for probabilistic models.
module Model

import Distribution
import Tensor

||| A `ProbabilisticModel` is a mapping from a feature domain to a probability distribution over
||| a target domain.
|||
||| @features The shape of the feature domain.
||| @targets The shape of the target domain.
||| @marginal The type of mulitvariate marginal distribution over the target domain.
public export 0
ProbabilisticModel : Distribution targets marginal => (0 features : Shape) -> Type
ProbabilisticModel features = {n : _} -> Tensor (Vect.(::) (S n) features) Double -> marginal (S n)


module Hittable

import Vec3
import Ray
import shapes.Sphere

%access export

public export

record HitRecord where
    constructor MkHitRecord
    p, normal  : Vec3
    t          : Double
    front_face : Bool
    isHitted   : Bool

set_face_normal : Ray -> Vec3 -> HitRecord -> HitRecord
set_face_normal ray outward_normal rec =
    record {
        -- front_face = dot (dir ray) outward_normal < 0.0
        normal = outward_normal
            -- then outward_normal
            -- else -outward_normal
        } rec

public export

interface Hittable s where
    hit : Ray -> Double -> Double -> s -> HitRecord

data HittableList = List (Sphere)

Hittable HittableList where
    hit ray t_min t_max list =
        map (hit ray t_min t_max) list


-- ----------------------------------------------------------- [ GLangPlus.idr ]
-- Module    : GLangPlus.idr
-- Copyright : (c) Jan de Muijnck-Hughes
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]

||| A alternate version of the GRL with added structural semantics.
module GRL.Lang.GLangPlus

import public GRL.Common
import public GRL.IR
import public GRL.Model
import public GRL.Builder
import public GRL.Pretty

%access public export

-- ------------------------------------------------------------- [ Type System ]

||| Specify valid impacts between elements.
data ValidImpacts : GElemTy -> GElemTy -> Type where
  GIS : ValidImpacts GOALty SOFTty
  SIG : ValidImpacts SOFTty GOALty
  TIG : ValidImpacts TASKty GOALty
  TIS : ValidImpacts TASKty SOFTty
  RIG : ValidImpacts RESty GOALty
  RIS : ValidImpacts RESty GOALty

||| Specify valid decomopositions.
data ValidDecomp : GElemTy -> GElemTy -> Type where
  GHS : ValidDecomp GOALty SOFTty
  THT : ValidDecomp TASKty TASKty

||| New structural types.
data GLangPTy = E GElemTy | L | S

||| The GLang Language with improved structural semantics.
data GLang : GLangPTy -> GTy -> Type where
  ||| Make a Goal node.
  MkGoal : String -> Maybe SValue -> GLang (E GOALty) ELEM
  ||| Make a Soft Goal node.
  MkSoft : String -> Maybe SValue -> GLang (E SOFTty) ELEM
  ||| Make a Task node.
  MkTask : String -> Maybe SValue -> GLang (E TASKty) ELEM
  ||| Make a resource node.
  MkRes  : String -> Maybe SValue -> GLang (E RESty)  ELEM

  ||| Declare an impact relation.
  MkImpact : CValue
          -> GLang (E xty) ELEM
          -> GLang (E yty) ELEM
          -> {auto prf : ValidImpacts xty yty}
          -> GLang L INTENT

  ||| And decomposition relation.
  MkAnd : GLang (E xty) ELEM
       -> GLang (E yty) ELEM
       -> {auto prf : ValidDecomp xty yty}
       -> GLang S STRUCT

-- ----------------------------------------------------------- [ Pretty Syntax ]

syntax [a] "~~>" [b] "|" [c] = MkImpact c a b
syntax [a] "&=" [b]          = MkAnd a b

-- ----------------------------------------------------------- [ Type Synonyms ]

GOAL : Type
GOAL = GLang (E GOALty) ELEM

SOFT : Type
SOFT = GLang (E SOFTty) ELEM

TASK : Type
TASK = GLang (E TASKty) ELEM

RES : Type
RES = GLang (E RESty) ELEM

IMPACT : Type
IMPACT = GLang L INTENT

AND : Type
AND = GLang S STRUCT

-- --------------------------------------------------------------------- [ GRL ]

implementation GRL (\x => GLang ty x) where
    mkElem (MkGoal s e) = Elem GOALty s e
    mkElem (MkSoft s e) = Elem SOFTty s e
    mkElem (MkTask s e) = Elem TASKty s e
    mkElem (MkRes  s e) = Elem RESty  s e

    mkIntent (MkImpact c a b) = ILink IMPACTSty c (mkElem a) (mkElem b)

    mkStruct (MkAnd a b) = SLink ANDty (mkElem a) [(mkElem b)]

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


import Data.IORef

count : HasReference ffi =>  Nat -> IORef Integer -> IO' ffi ()
count Z ref
    = do x <- readIORef' ref
         printLn' x
count (S k) ref
    = do modifyIORef' ref (+1)
         count k ref

main : IO ()
main = do r <- newIORef' 0
          count 1000 r


module TypedContainers.In

import Data.List
import Data.List.Elem
import Data.DPair

%default total

lemma0 : ([x] = [y]) -> (x = y)
lemma0 Refl = Refl

lemma1 : {0 xs : List a} -> {0 ys : List a} -> ((x :: xs) = (y :: ys)) -> (xs = ys)
lemma1 Refl = Refl

lemma2 : {0 xs : List a} -> {0 ys : List a} -> ((x :: xs) = (y :: ys)) -> (x = y)
lemma2 Refl = Refl

public export
data In : (a -> Bool) -> List a -> Type where
  MkIn : (x : a) -> (f x = True) -> (xs : List a) -> In f (x :: xs)
  MkInCons : (x : a) -> (0 xs : List a) -> In f xs -> In f (x :: xs)

public export
inFilter : (f : a -> Bool) -> (g : a -> Bool) -> ((x : a) -> (g x = True) -> f x = True) -> (l : List a) -> In g l -> In g (filter f l)
inFilter f g p1 [] p2 impossible
inFilter f g p1 (x :: xs) (MkIn x p2 xs) =
  let p3 = p1 x p2 in
  rewrite p3 in MkIn x p2 (filter f xs) {f = g}
inFilter f g p1 (x :: xs) (MkInCons x xs p2) =
  let r = inFilter f g p1 xs p2 in
  let MkDPair p2 p3 : DPair Bool (f x ===) = MkDPair (f x) Refl in
  case p2 of
    True => rewrite p3 in MkInCons x (filter f xs) r
    False => rewrite p3 in r

fromFilter : {f : a -> Bool} -> {l : List a} -> {lEq : l' === filter f l} -> Elem x l' -> (f x = True)
fromFilter (Here {x, xs}) = case l of
  [] impossible
  y :: ys =>
    let (MkDPair p0 p1) : DPair Bool ((f y) ===) = MkDPair (f y) Refl in
    case p0 of
      True =>
        let p2 : (y :: filter f ys = filter f (y :: ys)) = rewrite p1 in Refl in
        let p3 : (x :: xs = y :: filter f ys) = rewrite p2 in lEq in
        let p4 = lemma2 p3 in
        rewrite p4 in p1
      False =>
        let p2 : (filter f ys = filter f (y :: ys)) = rewrite p1 in Refl in
        let p3 : (x :: xs = filter f ys) = rewrite p2 in lEq in
        fromFilter {f, l = ys, lEq = p3} (Here {x, xs})
fromFilter (There p {x, y, xs}) =
  case l of
    [] impossible
    z :: zs =>
      let (MkDPair p0 p1) : DPair Bool ((f z) ===) = MkDPair (f z) Refl in
      case p0 of
        True =>
          let p2 : (z :: filter f zs = filter f (z :: zs)) = rewrite p1 in Refl in
          let p3 : (y :: xs = z :: filter f zs) = rewrite p2 in lEq in
          let p4 = lemma1 p3 in
          fromFilter {f, lEq = p4} p
        False =>
          let p2 : (filter f zs = filter f (z :: zs)) = rewrite p1 in Refl in
          let p3 : (y :: xs = filter f zs) = rewrite p2 in lEq in
          fromFilter {f, lEq = p3} (There p {x, y, xs})

extractIn' : {f : a -> Bool} -> {g : a -> Bool} -> {l : List a} -> {l' : List a} -> {lEq : l' = filter g l} -> In f l' -> DPair a (\x => (f x = True, g x = True))
extractIn' (MkIn x p0 xs) =
  let p1 = Here {x, xs} in
  let p2 = fromFilter {f = g, l, l' = x :: xs, lEq} p1 in
  MkDPair x (p0, p2)
extractIn' (MkInCons x xs rec) =
  case l of
    [] impossible
    y :: ys =>
      let (MkDPair p2 p3) : DPair Bool ((g y) ===) = MkDPair (g y) Refl in
      case p2 of
        True =>
          let p4 : (y :: filter g ys = filter g (y :: ys)) = rewrite p3 in Refl in
          let p5 : (x :: xs = y :: filter g ys) = rewrite p4 in lEq in
          extractIn' {f, g, l = ys, l' = xs, lEq = lemma1 p5} rec
        False =>
          let p4 : (filter g ys = filter g (y :: ys)) = rewrite p3 in Refl in
          let p5 : (x :: xs = filter g ys) = rewrite p4 in lEq in
          extractIn' {f, g, l = ys, l' = x :: xs, lEq = p5} (MkInCons x xs rec)

public export
extractIn : {f : a -> Bool} -> {g : a -> Bool} -> {l : List a} -> In f (filter g l) -> DPair a (\x => (f x = True, g x = True))
extractIn = extractIn' {lEq = Refl}

outFilter' : {0 f : a -> Bool} -> {g : a -> Bool} -> (xxs : List a) -> (pl : yys = filter g xxs) -> In f yys -> In f xxs
outFilter' [] pl (MkIn _ _ _) impossible
outFilter' [] pl (MkInCons _ _ _) impossible
outFilter' (x :: xs) pl (MkIn y py ys) with (g x)
  outFilter' (x :: xs) pl (MkIn y py ys) | True =
    let pl' = lemma2 pl in
    let px : (f x = True) = rewrite sym pl' in py in
    MkIn x px xs
  outFilter' (x :: xs) pl (MkIn y py ys) | False = MkInCons x xs $ outFilter' {f, g} xs pl (MkIn {f} y py ys)
outFilter' (x :: xs) pl (MkInCons y ys py) with (g x)
  outFilter' (x :: xs) pl (MkInCons y ys py) | True = MkInCons x xs $ outFilter' {f, g} xs (lemma1 pl) py
  outFilter' (x :: xs) pl (MkInCons y ys py) | False = MkInCons x xs $ outFilter' {f, g} xs pl (MkInCons y ys py)

public export
outFilter : {g : a -> Bool} -> {l : List a} -> In f (filter g l) -> In f l
outFilter p = outFilter' {f, g} l Refl p


module Data.Schema

import public Control.Delayed

import public Data.Bool
import public Data.List1
import public Data.List

import public Data.Schema.Restricted

%default total

public export
data Valid : Type -> Type where
  IsString : Valid String
  IsChar   : Valid Char
  IsNat    : Valid Nat

public export
data Atom : (name : Type) -> Type where
  MkAtom : (n           : name)
        -> (v           : Type)
        -> (restriction : Schema.Restriction type)
        -> (prf         : Valid type)
                       -> Atom name

public export
data Schema : (name : Type) -> Bool -> Type where
  ||| The empty schema.
  Empty : Schema n False

  ||| A schema with a single component.
  Simple : Atom n -> Schema n True

  ||| A named schema with sub-schema.
  Complex : (name   : n)
         -> (schema : Schema n a)
                   -> Schema n a

  ||| Sequence two schemas where `that` might be infinite.
  SeqEat : (this :      Schema n True)
        -> (that : Inf (Schema n b))
                 ->     Schema n True

  ||| Sequence two schemas where `that` is not infinite.
  SeqEmpty : (this : Schema n  a)
          -> (that : Schema n       b)
                  -> Schema n (a || b)

  ||| Choice between two schemas.
  Alt : (this : Schema n  a)
     -> (that : Schema n       b)
             -> Schema n (a && b)

namespace API
  public export
  Schema : Type -> Type
  Schema n = Schema n True

--public export %inline
--(<+>) : {a : Bool}
--     -> (this :        Schema n  a)
--     -> (that : inf a (Schema n       b))
--             ->        Schema n (a || b)
--(<+>) {a = False} = SeqEmpty
--(<+>) {a = True}  = SeqEat

%allow_overloads (<|>)

public export %inline
(<|>) : Schema n  a
     -> Schema n       b
     -> Schema n (a && b)
(<|>) = Alt

public export
opt : (s : Schema n True) -> Schema n False
opt s = s <|> Empty

mutual
  public export
  some : Schema n -> Schema n
  some l = SeqEat l (many l)

  public export
  many : Schema n -> Schema n False
  many l = opt (some l)

public export
select : (xs  : List (Schema n b))
      -> (prf : NonEmpty xs) -- so we can use prettier list notation.
             => Schema n b
select (x :: xs) {prf = IsNonEmpty}
    = foldl build x xs
  where
    build : Schema n b -> Schema n b -> Schema n b
    build acc x = rewrite sym (andSameNeutral b) in (acc <|> x)

public export
concat : (xs  : List (Schema n b))
      -> (prf : NonEmpty xs) -- so we can use prettier list notation.
             => Schema n (b && True)
concat (x :: xs) {prf = IsNonEmpty}
      = concat' (x::xs)

  where
    concat' : (xs : List (Schema n b))
                 ->       Schema n (b && isCons xs)
    concat' []
      = rewrite andFalseFalse b in Empty

    concat' (x :: xs)
      = rewrite andTrueNeutral b in
        rewrite sym (orSameAndRightNeutral b (isCons xs)) in
          SeqEmpty x (concat' xs)

-- [ EOF ]


module Gspider.Types.RestrictedCharString

import Data.So

%access private

||| Returns true if the given list of characters `str` contains only characters specified in `chars`.
|||
||| @chars the list of permitted characters
||| @str the string to check
madeOf' : (chars : List Char) -> (str : List Char) -> Bool
madeOf' chars [] = True
madeOf' chars (x :: xs) = elem x chars && madeOf' chars xs

||| Returns true if the given string `str` contains only characters specified in `chars`.
|||
||| @chars the list of permitted characters
||| @str the string to check
export
madeOf : (chars : List Char) -> (str : String) -> Bool
madeOf chars str = madeOf' chars (unpack str)

||| Strings that are restricted to only a specific set of characters.
|||
||| @allowed the list of characters allowed in the string
public export
data RestrictedCharString : (allowed : List Char) -> Type where
  ||| Constructs a restricted character set string with the specified value.
  |||
  ||| @val the value of the string
  MkRestrictedCharString : (val : String) ->
                           {auto prf : So (madeOf allowed val)} ->
                           RestrictedCharString allowed

||| Attempts to restricts a string to contain only a specific set of characters.
|||
||| @chars the list of characters allowed in the string
||| @str the string to attempt to restrict
export
restrictStr : (chars : List Char) -> (str : String) -> Maybe (RestrictedCharString chars)
restrictStr chars str = case choose (madeOf chars str) of
  Left _ => Just (MkRestrictedCharString str)
  Right _ => Nothing

||| Converts a list of strings to a list of strings with a restricted character set, where possible.
|||
||| @chars the set of characters to use to restrict strings
||| @strs the list of strings to convert
export
convertToRestricted : (chars : List Char) -> (strs : List String) -> List (RestrictedCharString chars)
convertToRestricted chars strs = catMaybes (map (restrictStr chars) strs)

||| Converts a string restricted to containing only a specific set of characters to an unrestricted string.
|||
||| @str the string to unrestrict
export
unrestrictStr : (str : RestrictedCharString _) -> String
unrestrictStr (MkRestrictedCharString str) = str

||| Converts a list of strings containing only a specific set of characters to a list of unrestricted strings.
|||
||| @strs the list of strings to convert
export
convertFromRestricted : (strs : List (RestrictedCharString _)) -> List String
convertFromRestricted strs = map unrestrictStr strs

||| Equality for restricted character set strings.
|||
||| @x some restricted character set string
||| @y some restricted character set string
equal : (x : RestrictedCharString s) -> (y : RestrictedCharString s) -> Bool
equal (MkRestrictedCharString u) (MkRestrictedCharString v) = u == v

||| Inequality for restricted character set strings.
|||
||| @x some restricted character set string
||| @y some restricted character set string
notEqual : (x : RestrictedCharString s) -> (y : RestrictedCharString s) -> Bool
notEqual (MkRestrictedCharString u) (MkRestrictedCharString v) = u /= v

||| Implement equality for restricted character set strings.
public export
Eq (RestrictedCharString s) where
  (==) = equal
  (/=) = notEqual

||| Comparison for restricted character set strings.
|||
||| @x some restricted character set string
||| @y some restricted character set string
compare' : (x : RestrictedCharString s) -> (y : RestrictedCharString s) -> Ordering
compare' (MkRestrictedCharString u) (MkRestrictedCharString v) = compare u v

||| Implement orderability for restricted character set strings.
public export
Ord (RestrictedCharString s) where
  compare x y = compare' x y


module Core.TT.Traversals

import Core.TT
import Core.Ord

import Data.DPair
import Data.SnocList
import Libraries.Data.NameMap
import Libraries.Data.SortedSet

%default covering

export
unBinds : Term vars -> Exists (\ outer => Term (outer <>> vars))
unBinds (Bind _ x _ scope) = let (Evidence outer t) = unBinds scope in
                             Evidence (outer :< x) t
unBinds t = Evidence [<] t

export
onPRefs : Monoid m =>
          (Name      -> m) ->
          (Term vars -> m)
onPRefs f = go neutral where

  go  : m -> Term vars' -> m
  gos : m -> List (Term vars') -> m

  go acc (Local fc isLet idx p) = acc
  go acc (Ref fc x name) = acc <+> f name
  go acc (Meta fc x y xs) = gos acc xs
  go acc (Bind fc x b scope) = go (acc <+> concatMap (onPRefs f) b) scope
  go acc (App fc fn arg) = go (go acc fn) arg
  go acc (As fc x as pat) = go (go acc as) pat
  go acc (TDelayed fc x y) = go acc y
  go acc (TDelay fc x ty arg) = go (go acc ty) arg
  go acc (TForce fc x y) = go acc y
  go acc (PrimVal fc c) = acc
  go acc (Erased fc imp) = acc
  go acc (TType fc u) = acc

  gos acc [] = acc
  gos acc (x :: xs) = gos (go acc x) xs

export
allGlobals : Term vars -> NameMap ()
allGlobals = onPRefs (\ n => singleton n ())

export
onConstants : Monoid m =>
          (Constant  -> m) ->
          (Term vars -> m)
onConstants f = go neutral where

  go  : m -> Term vars' -> m
  gos : m -> List (Term vars') -> m

  go acc (Local fc isLet idx p) = acc
  go acc (Ref fc x name) = acc
  go acc (Meta fc x y xs) = gos acc xs
  go acc (Bind fc x b scope) = go (acc <+> concatMap (onConstants f) b) scope
  go acc (App fc fn arg) = go (go acc fn) arg
  go acc (As fc x as pat) = go (go acc as) pat
  go acc (TDelayed fc x y) = go acc y
  go acc (TDelay fc x ty arg) = go (go acc ty) arg
  go acc (TForce fc x y) = go acc y
  go acc (PrimVal fc c) = acc <+> f c
  go acc (Erased fc imp) = acc
  go acc (TType fc u) = acc

  gos acc [] = acc
  gos acc (x :: xs) = gos (go acc x) xs

export
allConstants : Term vars -> SortedSet Constant
allConstants = onConstants @{MkMonoid @{MkSemigroup union} empty} singleton

export
mapTermM : Monad m =>
           ({vars : _} -> Term vars -> m (Term vars)) ->
           ({vars : _} -> Term vars -> m (Term vars))
mapTermM f t = act t where

  act : {vars : _} -> Term vars -> m (Term vars)
  go  : {vars : _} -> Term vars -> m (Term vars)

  act t = f =<< go t

  go t@(Local fc isLet idx p) = pure t
  go t@(Ref fc x name) = pure t
  go t@(Meta fc x y xs) = Meta fc x y <$> traverse act xs
  go t@(Bind fc x b scope) = Bind fc x <$> traverse act b <*> act scope
  go t@(App fc fn arg) = App fc <$> act fn <*> act arg
  go t@(As fc x as pat) = As fc x <$> act as <*> act pat
  go t@(TDelayed fc x y) = TDelayed fc x <$> act y
  go t@(TDelay fc x ty arg) = TDelay fc x <$> act ty <*> act arg
  go t@(TForce fc x y) = pure t
  go t@(PrimVal fc c) = pure t
  go t@(Erased fc imp) = pure t
  go t@(TType fc u) = pure t


record Foo where
  constructor MkFoo
  a : Nat
  b : Nat

foo1 : Foo
foo1 = MkFoo
  { a = 1
  , a = 2
  , b = 3
  }

foo2 : Foo
foo2 =
  { a := 3
  , a := 4
  , b := 2
  , b := 1
  } foo1


module Keypad

import Data.Vect

%default total

export
record Keypad where
  constructor MkKeypad
  -- 16 key hexadecimal keypad
  K : Vect 16 Bool

export
Show Keypad where
  show k = show (K k)

export
isKeyPressed : (keypad : Keypad) -> (n : Fin 16) -> Bool
isKeyPressed keypad n = Vect.index n (K keypad)

export
setKeyPress : (keypad : Keypad) -> (n : Fin 16) -> Keypad
setKeyPress keypad n =
  let newK = Vect.replaceAt n True (K keypad) in
  record { K = newK } keypad

export
clearKeyPress : (keypad : Keypad) -> (n : Fin 16) -> Keypad
clearKeyPress keypad n =
  let newK = Vect.replaceAt n False (K keypad) in
  record { K = newK } keypad


module Main

import Data.Hash

main : IO ()
main = do printLn $ hash (the Bits8 3)
          printLn $ hash (the (List Bits8) [3])
          printLn $ hash "hello world"
          printLn $ hash 'a'
          printLn $ hash (the Bits8 3)
          printLn $ hash (the Bits16 3)
          printLn $ hash (the Bits32 3)
          printLn $ hash (the Bits64 3)
          printLn $ hash (the Int 3)
          printLn $ hash (the Integer 3)
          printLn $ divB8 10 255
          printLn $ divB16 10 65535
          printLn $ divB32 10 4294967295
          printLn $ divB64 10 18446744073709551615


data PowerSource = Petrol | Pedal | Electric

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

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

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Bus 200
refuel Bicycle impossible
refuel Unicycle impossible
refuel (Motorcycle fuel) = Motorcycle 50

bmw : Vehicle Petrol
bmw = Car 20

cube : Vehicle Pedal
cube = Bicycle

let x = refuel bmw
let y = refuel cube