quox/lib/Quox/Thin/Base.idr

module Quox.Thin.Base

import Data.Fin
import Data.DPair

%default total

||| "order preserving embeddings", for recording a correspondence between a
||| smaller scope and part of a larger one. the third argument is a bitmask
||| representing this OPE, unique for a given `n`.
public export
data OPE : (m, n, mask : Nat) -> Type where
  [search m n]
  Stop : OPE 0 0 0
  Drop : OPE m n mask -> mask' = mask + mask       -> OPE m     (S n) mask'
  Keep : OPE m n mask -> mask' = (S (mask + mask)) -> OPE (S m) (S n) mask'
%name OPE ope

export
Show (OPE m n mask) where
  showPrec d Stop            = "Stop"
  showPrec d (Drop ope Refl) = showCon d "Drop" $ showArg ope ++ " Refl"
  showPrec d (Keep ope Refl) = showCon d "Keep" $ showArg ope ++ " Refl"

public export %inline
drop : OPE m n mask -> OPE m (S n) (mask + mask)
drop ope = Drop ope Refl

public export %inline
keep : OPE m n mask -> OPE (S m) (S n) (S (mask + mask))
keep ope = Keep ope Refl


public export
data IsStop : OPE m n mask -> Type where ItIsStop : IsStop Stop

public export
data IsDrop : OPE m n mask -> Type where ItIsDrop : IsDrop (Drop ope eq)

public export
data IsKeep : OPE m n mask -> Type where ItIsKeep : IsKeep (Keep ope eq)


export
0 zeroIsStop : (ope : OPE m 0 mask) -> IsStop ope
zeroIsStop Stop = ItIsStop


||| everything selected
public export
id : {m : Nat} -> Subset Nat (OPE m m)
id {m = 0}   = Element _ Stop
id {m = S m} = Element _ $ Keep id.snd Refl

public export %inline
0 id' : {m : Nat} -> OPE m m (fst (Base.id {m}))
id' = id.snd

||| nothing selected
public export
zero : {m : Nat} -> OPE 0 m 0
zero {m = 0}   = Stop
zero {m = S m} = Drop zero Refl

||| a single slot selected
public export
one : Fin n -> Subset Nat (OPE 1 n)
one FZ     = Element _ $ keep zero
one (FS i) = Element _ $ drop (one i).snd

public export %inline
0 one' : (i : Fin n) -> OPE 1 n (one i).fst
one' i = (one i).snd


public export
record SomeOPE n where
  constructor MkOPE
  {0 scope : Nat}
  {mask : Nat}
  0 ope : OPE scope n mask