data Foo :: ... where ...

data Foo :: ... where ...

-- Modeling Opetopes
-- here is Eric's editor: http://sma.epfl.ch/~finster/opetope/opetope.html
--
-- Note: Kock et al. use a similar scheme, where
--          - dots    <-->   lines
--          - spheres <-->   dots
--          - lines disappear
--          -                spheres appear

-- Note: In Eric's new work (at IAS) there are no
--       dots any more, instead he uses 'external cards', so
--          - (external) cards   <-->  lines
--          - space between stacked cards <--> external cards
--          - lines disappear
--          -                (regular) cards appear

import "../src/LangPrelude.prg" (maybeM)
import "../tests/Nat.prg"

##bounds backchain 10

-- GLOBAL TODOs
----------------

-- Naming: Seems essential for identifying things Hor(Name), Ver(Tree)
--         Name can be Label, then Niches (= sequences of opetope names).
--         the latter arise from the composition rule.
--         Note: don't store names in Stacks, that kills alpha
--               conversion. Instead names should be pushed into nodes
--               'singleton style' from outside: (node :: Tree (Hor `g))

-- Morphisms: given an opetope and a pointer to one of its cards
--            extract the opetope of that face (do we need a label
--            space to reliably find it?). This must be a type
--            function, with an algorithm accompanying it to extract
--            the face proper.

-- Composition: grafting of trees to external cards, but only if the
--              morphisms (faces) match. lower-dim stuff is unaffected.

-- Swapping: given a proof of equality between two niches, provide an
--           operation to swap them, replacing old faces by new ones,
--           FGL-style (functional graph library), just note that
--           certain morphisms are gone, others appeared.

-- References: a disciplined way of saying "I am an identical node to that guy",
--             by corollary these always obtain the same names.
--             a topologist would say 'surgery' (http://en.wikipedia.org/wiki/Surgery_theory)
--             We get a new Tree flavour, Ref, at least one up, followed by
--             naturals to index a node in a subtree.
--             At this point we are doing algebraic topology, and dealing with
--             closed manifolds, so that we can do homology etc. on them.
--             In logic this corresponds to relations, satisfiability.
--             NB.: It is not enough to make O cartesian. I also need
--                  a way to invoke specific inference rules from my logic.
--                  I must be able to parse a tree into a semantics, i.e.
--                  have binding stations, deBruijn/global references,
--                  punctuation, rule invocation etc. The key to all this
--                  are non-occupied "binding stations" which encode the
--                  additional linguistic stuff. This includes 'data'
--                  declarations, i.e. axioms, naming contexts, exports.
--                  This is the canned presheaf Eric speaks about in the
--                  video, that has its free brother in Cat.

-- Quoting: So far we have only dealt with data, i.e. quoted (inert) syntax.
--          we need a way to convert this syntax to code (e.g. at some stage),
--          to obtain semantics. We can have the usual splicing game.
--          Lisp does this with sexprs and macros.
--          The code needs then be executed (run, decreasing stage), when
--          it becomes active, and we can observe the manifestation of its
--          semantics. The reduction system could go along the lines of the
--          (typed) LambdaGraph.

-- NbE: I fully believe we can use this technique to reduce opetopic terms
--      to normal form. ('many syntax', 'one semantics' adjunction:
--                       http://www.logicmatters.net/resources/pdfs/Galois.pdf)

-- Cartesian Closure: Creating 'lambda cards' by the above technology
--                    seems very ad-hoc and arbitrary. Contrast it with more
--                    serious attempts like higher-order containers
--                    (http://www.cs.nott.ac.uk/~txa/publ/hocont.pdf)
--                    or other ways to create internal languages.

-- TODO: these three must be LeftLists
--
kind Trees = NoTree | Pre (Tree d) Trees deriving syntax (ts) List(NoTree, Pre)

data ZoomCompley :: Tree e ~> Tree f ~> * where
  Nily :: ZoomCompley a a
  Consy :: Stack a b -> ZoomCompley b c -> ZoomCompley a c
 deriving List(cply)

data ZoomComplex :: Trees ~> * where
  Nilx :: ZoomComplex [()tr]ts
  Endx :: Stack a b -> ZoomComplex [a, b]ts
  Consx :: Stack a b -> ZoomComplex [b; c]ts -> ZoomComplex [a, b; c]ts
 deriving syntax (cplx) List(Nilx, Consx) Item(Endx)

data Dir :: *2 where
  Hor :: Dir
  Ver :: Dir

-- define the Tree kind, a rose tree
-- note: we may need a two-level kind, since we need to track disjointness
--       of subtrees
-- todo: later we may want to have a label kind parameter too

data Tree :: Dir ~> *1 where
  Unit :: Tree Ver
  Ni :: Tree Hor
  Fork :: Tree d ~> Tree Hor ~> Tree Hor
 deriving syntax (tr) List(Ni, Fork) Unit(Unit)

-- make it singleton

data Tree' :: Tree d ~> * where
  In :: Tree' ()tr
  Fork :: treelike head -> Tree' tail -> Tree' [head; tail]tr
  Done :: Tree' []tr
 deriving syntax (ar) List(Done, Fork) Unit(In) -- "arbre"
-- http://www.papoulipoesique.com/wp-content/uploads/2013/06/arbre.jpg

-- define a proposition for subtrees
-- to be checked: TakeHead must ensure that all the node is consumed

prop Subtree :: Tree d ~> Tree e ~> * where
  UnitSub :: Subtree ()tr tr
  BothNil :: Subtree []tr []tr
  TakeHead :: Subtree head head' -> Subtree tail tail' -> Subtree [head; tail]tr [head'; tail']tr

-- TODO: separate the notions of Niche / Frame / Cell
kind Volume = FramedHollow | FilledCell
kind Diagram = Closed Volume | OpenNiche
-- should be a parameter to Stack

-- now we can stack cards (these are zooms in Kock et al. parlance)

data Stack :: Tree d ~> Tree e ~> * where
  Corolla :: Corolla tr => Tree' tr -> Stack tr ()tr

  -- TODO: needed?
  --Expand :: (Subtree consumed tr, {nodeValence consumed} `Equal` {nodeValence tr}) => Stack consumed prod -> Stack tr prod

  -- add another target face to a web
  Target :: ({nodes tr} `Equal` {nodeValence out}) => Stack tr out -> Stack tr out

  -- the following three grab a node (and possibly its offsprings) and incorporate it into a single card
  NodeDone :: Stack []tr [()tr]tr
  Pick :: {- EntireNode => -} Stack head prodhead -> Stack tail prodtail -> Stack [head; tail]tr [prodhead; prodtail]tr
  Exclude :: {- EntireNode => -} Stack tail prod -> Stack [()tr; tail]tr prod
  -- TODO: maybe just specify a subtree (Tree') and that's it

  On :: (Subtree tr' tr, Pointers 1t at out) => Stack tr' out' -> Stack tr out -> Tree' at -> Stack tr {graft out' at out}

  -- building niches (pasting diagrams)
  -- TODO: these must produce a composite labelled Hor
  NicheDone :: Stack ()tr []tr
  Niche :: Stack tr out -> Stack tr [out]tr
  Also :: Pointers 1t at tr
       => Tree' at -> Stack tr' out' -> Stack tr out -> Stack {extgraft tr' at tr} [out'; out]tr

  -- put a frame around a niche
  Frame :: (Corolla out, {nodes tr}  `Equal` {nodeValence out}) => Stack tr out -> Stack tr out

 deriving syntax(z) Record(NicheDone, Also) Item(Target)

stop = ({}z)z

-- this is bogus, just make it compile again...
up :: Reference tr => Stack ()tr tr -> Stack ()tr [tr]tr
up inner = ({()ar=inner}z)z

-- it remains to define corollas

-- TODO: one could say {nodes tr} == 1
prop Corolla :: Tree d ~> * where
  None' :: Corolla []tr
  One' :: Corolla tail -> Corolla [()tr; tail]tr

--  o   --->  |
--  |         |

lolliCell :: Stack []tr ()tr
lolliCell = Corolla Done

--  |         |
--  o   --->  |
--  |         |

dolliCell :: Stack [()tr]tr ()tr
dolliCell = Corolla $ Fork In Done

--              |
--  [o]   --->  o
--   |          |

lolliFrame :: Stack []tr [()tr]tr
lolliFrame = Target NodeDone

--   |          |
--  [o]   --->  o
--   |          |

dolliFrame :: Stack [()tr]tr [()tr]tr
dolliFrame = Target (Exclude NodeDone)

--   |          |
--   |          o
-- [[o]]  --->  |
--   |          o
--   |          |

stacked :: Stack [()tr]tr [[()tr]tr]tr
stacked = (dolliFrame `On` dolliFrame) (In `Fork` Done)

--   |
--  [|]   --->  o
--   |          |

crossed :: Stack ()tr []tr
crossed = stop

-- we can now join things
--
dolliForever = [dolliFrame; dolliForever]cply
nopetope = [crossed, lolliFrame; dolliForever]cply

-- back to unit as fast as possible...
--
stopetope = [crossed, lolliFrame, dolliCell]cply
neverstopetope = [crossed, lolliFrame, dolliCell; neverstopetope]cply
stopetope' = [crossed, lolliFrame; (dolliCell)cplx]cplx
stopetope'' = [crossed, lolliFrame, dolliCell]cplx

--   |          o
-- [[|]]  --->  |
--   |          o
--   |          |

drossed :: Stack ()tr [[]tr]tr
drossed = up stop

-- ################################
-- ############  Niches ###########
-- ################################

--  |          +
--  |          |

-- this is a niche, but assume to be a frame
niche0 :: Stack ()tr []tr
niche0 = {}z

--  |           |
-- [|]          +
--  |           |

-- this is a niche, but assume to be a frame
niche1 :: Stack ()tr [[]tr]tr
niche1 = {()ar=stop; {}z}z

--  |         o   o
-- [|]  --->   \ /
-- [|]          +
--  |           |

-- this is a niche, but assume to be a frame
niche2 :: Stack ()tr [[]tr, []tr]tr
niche2 = {()ar=stop; niche1}z

--                |
--  |         o   o
-- [o]  --->   \ /
-- [|]          +
--  |           |

niche10 :: Stack [()tr]tr [[()tr]tr, []tr]tr
niche10 = {()ar=Exclude NodeDone; Niche stop}z

-- ################################
-- ############  Frames ###########
-- ################################

--   |              |
--  /|\         o   o
-- |[o]|  --->   \ /
-- |[|]|          o
--  \|/           |
--   |

cyclops :: Stack [()tr]tr [[()tr]tr, []tr]tr
cyclops = (niche10)z

-- Stacking, Valence, Affine subtree, Substitute at an affine position

-- counting Units in a tree

valence :: Tree d ~> Nat
{valence []tr} = 0t
{valence [head; tail]tr} = {plus {valence head} {valence tail}}
{valence ()tr} = 1t

-- counting siblings of a tree

nodeValence :: Tree d ~> Nat
{nodeValence []tr} = 0t
{nodeValence [head; tail]tr} = (1+{nodeValence tail})t

-- counting nodes in a tree

nodes :: Tree d ~> Nat
{nodes ()tr} = t
{nodes []tr} = 1t
{nodes [head; tail]tr} = {plus {nodes head} {nodes tail}}

-- nodeValenceAt: given a (multi)pointer, determine the node valences at those positions
--               WHERE     IN
nodeValenceAt :: Tree d ~> Tree e ~> Nat
{nodeValenceAt ()tr tree} = {nodeValence tree}
{nodeValenceAt []tr []tr} = 0t
{nodeValenceAt [head'; tail']tr [head; tail]tr} = {plus {nodeValenceAt head' head} {nodeValenceAt tail' tail}}

-- a pointer is a valence-1 subtree of a tree
-- it is used to mark a unit in a tree where substitution will occur
--
prop Pointers :: Nat ~> Tree d ~> Tree e ~> * where
  Finger :: Pointers 1t ()tr ()tr
  Finished :: Pointers 0t []tr []tr
  ThisWay :: Pointers 1t head' head -> Pointers n tail' tail -> Pointers (1+n)t [head'; tail']tr [head; tail]tr
  ElseWhere :: Pointers n tail' tail -> Pointers n [[]tr; tail']tr [head; tail]tr

-- http://en.wikipedia.org/wiki/Grafting
--
-- graft WHAT      WHERE     IN
graft :: Tree d ~> Tree e ~> Tree f ~> Tree f
{graft what ()tr ()tr} = what
{graft what []tr tr} = tr
{graft what [head'; tail']tr [head; tail]tr} = [{graft what head' head}; {graft what tail' tail}]tr

-- extgraft: extend and graft
--
extgraft :: Tree what ~> Tree wher ~> Tree tree ~> Tree tree'
{extgraft what ()tr ()tr} = what
{extgraft what []tr ()tr} = ()tr
{extgraft what [head; tail]tr ()tr} = {extgrafthor what [head; tail]tr}
{extgraft what []tr []tr} = []tr
{extgraft what []tr [head; tail]tr} = [head; tail]tr
{extgraft what [head'; tail']tr [head; tail]tr} = [{extgraft what head' head}; {extgraft what tail' tail}]tr

-- helper:
extgrafthor :: Tree what ~> Tree Hor ~> Tree Hor
{extgrafthor what []tr} = []tr
{extgrafthor what [head; tail]tr} = [{extgraft what head ()tr}; {extgrafthor what tail}]tr

{- NOTE: we have an Omega bug here:

prompt> :norm {graft []tr ()tr ()tr}
Normalizes to:
  []tr

prompt> :kind []tr
[]tr :: Tree Hor  = []tr

prompt> :kind {graft []tr ()tr ()tr}
{graft []tr ()tr ()tr} :: Tree Ver  = {graft []tr ()tr ()tr}

... BUT: Hor /= Ver :-(
-}

-- substitution: replace a pointed node (of valence n) in a tree with an
-- other tree of (valence n) -- TODO

-- HERE IS A NICE RESEARCH QUESTION:
-- is it possible to "proof search" a Zoom?
-- i.e.
{-

class ZoomLike (int :: Tree) (out :: Tree) where
  zoom :: (Nodes int ~ Valence out) => Zoom int out

-}

prop Reference :: Tree Hor ~> * where
  Stop :: Reference []tr
  Up :: Reference tr -> Reference [tr]tr
 deriving Nat(d) -- de Bruijn index

prop Teleport :: Tree Hor ~> * where
  Gate :: Teleport [()tr]tr
  Tele :: Teleport tr -> Teleport [tr]tr
 deriving Nat(sk) -- skips

{-

0
|   |
1   L  (lambda node)
|   |
2   1  (how many skips)
 \ /
  o
  |
  B  (binds here)
  |

Encodes \x.xx

-}

r2 = 2d
t1 = 1sk

lamX_XX = addBinder $ [r2, t1]ar

prop BindsUp :: Nat ~> Tree Hor ~> * where
  LastSkip :: BindsUp 1t [()tr]tr
  MoreSkip :: Teleport tr -> BindsUp n tr -> BindsUp (1+n)t [tr]tr
  -- prove Application node
  HeadBindsUp :: Nat' n -> BindsUp (1+n)t head -> BindsUp n [head; tail]tr
  TailBindsUp :: BindsUp n [head; tail]tr -> BindsUp n [nonempty, head; tail]tr

-- TODO: make sure that something teleports here
addBinder :: BindsUp 1t tr => Tree' tr -> Tree' [tr]tr
addBinder term = [term]ar

testB :: BindsUp 0t [[[[]tr]tr]tr,[()tr]tr]tr -> Tree' [[[[]tr]tr]tr,[()tr]tr]tr
testB ev = [r2, 0sk]ar
testB' = testB (TailBindsUp (HeadBindsUp 0v (LastSkip)))

testC :: BindsUp 0t [[[[[]tr]tr]tr,[[()tr]tr]tr]tr]tr -> Tree' [[[[[]tr]tr]tr,[[()tr]tr]tr]tr]tr
testC ev = lamX_XX
testC' = testC (HeadBindsUp 0v (TailBindsUp (HeadBindsUp 1v (MoreSkip 0sk LastSkip))))

--TODO: prop Lambda :: Tree Hor ~> * where

{-
The slogan is: binder nodes do not count as result nodes:
 - just consider the next node upstream
 - incoming (external) cards, when identified to a binder do not count as inputs to application
 - incoming (external) cards, when identified to an (iterated) application become pattern matching (sigma).

In the end all identifications have a semantics (hopefully!), when the counting rules are ensured.

-}

-- Now some fun stuff

data LC :: Shape ~> (k ~> *) ~> * where
  Var :: tf a -> LC (Rf a) tf
  App :: LC fsh tf -> LC ash tf -> LC (fsh `Ap` ash) tf
  Lam :: tf a -> LC sh tf -> LC (Lm sh) tf
  LetRec :: tf a -> LC ish tf -> LC esh tf -> LC ((Lm esh) `Ap` ish) tf
 deriving syntax (lc) Applicative(Var, App, Lam, LetRec)

alamX_XX = (\x->x x)lc

kind Dict key value = Dempty | Dextend (Dict key value) key value deriving LeftRecord(dict)

-- Contexts map keys to some value
--
data Context :: (key ~> *) ~> (value ~> *) ~> Dict key value ~> * where
  Empty :: Context key value {}dict
  Extend :: Context key value dict -> key k -> value v -> Context key value {dict; k = v}dict
 deriving LeftRecord(ctx)

-- DeBruijn levels as keys
--
dictSize :: Dict key value ~> Nat
{dictSize {}dict} = 0t
{dictSize {pre; k = v}dict} = (1+{dictSize pre})t

data DeBruijnContext :: (value ~> *) ~> Dict Nat value ~> * where
  DeBruijnEmpty :: DeBruijnContext value {}dict
  DeBruijnExtend :: DeBruijnContext value dict -> value v -> DeBruijnContext value {dict; {dictSize dict} = v}dict
 deriving LeftList(dtx)

getDeBruijnIndex :: Dict key value ~> value ~> Nat ~> Nat
{getDeBruijnIndex {pre; k = v}dict v acc} = acc
{getDeBruijnIndex {pre; k = v'}dict v acc} = {getDeBruijnIndex pre v (1+acc)t}

lookUpDeBruijn :: DeBruijnContext Label dict -> Label l -> Nat' acc -> Maybe (Nat' {getDeBruijnIndex dict l acc})
lookUpDeBruijn []dtx _ _ = Nothing
lookUpDeBruijn [pre; known]dtx lab acc = case sameLabel known lab of
                                         R _ -> lookUpDeBruijn pre lab (1+acc)t
                                         L Eq -> Just acc

monad maybeM

l2n :: Shape ~> Shape
{l2n (Lm sh)} = Lm {l2n sh}
{l2n (Ap f a)} = Ap {l2n f} {l2n a}
{l2n (Rf t)} = Rf n -- getDeBruijnIndex!!! FIXME

toDeBruijn :: DeBruijnContext Label dict -> LC sh Label -> Maybe (LC {l2n sh} Nat')
toDeBruijn ctx (Var a) = do idx <- lookUpDeBruijn ctx a 0t
                            return $ Var idx
toDeBruijn ctx (Lam l a) = do a' <- toDeBruijn [ctx; l]dtx a
                              return $ Lam 0t a'
toDeBruijn ctx (App f a) = do f' <- toDeBruijn ctx f
                              a' <- toDeBruijn ctx a
                              return $ App f' a'

-- we should get a pair (Nat, Context) -- TODO
-- this is not good yet!
--
{-
toFullContext :: DeBruijnContext Nat' dict -> Shape' sh -> LC sh Nat' -> LC sh (Context Nat' Shape')
toFullContext ctx (Rf a') (Var a) = Var ctx
toFullContext ctx sh (Lam l a) = Lam ctx $ toFullContext [ctx; l]dtx a
toFullContext ctx sh (App f a) = App (toFullContext ctx f) (toFullContext ctx a)
-}

-- Let :: tf a -> LC tf -> LC tf -> LC tf -- not needed!
pattern Let n v exp = App (Lam n exp) v

-- fun with church encoding

true = (\t->\f->t)lc
--false = (\t f->f)lc -- BUG!
false = (\t->\f->f)lc

-- church 'if'
chif = (\v->\iftrue->\iffalse->v iftrue iffalse)lc

chtest = (chif true false true)lc -- will not do what you expect
--chtest' = ($chif $true $false $true)lc -- not ready yet!

chtest'' = (let { true = \t->\f->t
                ; false = \t->\f->f
                ; chif = \v->\iftrue->\iffalse -> v iftrue iffalse
                }
            in chif true false true)lc -- this still does not work :-(

letrecToLet :: LC sh k -> LC sh k
letrecToLet (App f a) = App (letrecToLet f) (letrecToLet a)
letrecToLet (v@Var _) = v
letrecToLet (l@Lam _ _) = l
letrecToLet (LetRec n v e) = App (Lam n e) v -- Let n v e -- Omega pattern bug???

l2l = letrecToLet (let a = a in a)lc

-- shapes

kind Shape = Lm Shape | Ap Shape Shape | Rf k

data Shape' :: Shape ~> * where
  Ref :: Nat' n -> Shape' (Rf n)
  Nam :: Label n -> Shape' (Rf n)
  Lm :: Shape' inner -> Shape' (Lm inner)
  Ap :: Shape' f -> Shape' a -> Shape' (f `Ap` a)

shape :: LC sh Nat' -> Shape' sh
shape (Var n) = Ref n
shape (Lam n e) = Lm $ shape e
shape (App f a) = shape f `Ap` shape a

{-
data Dictionary :: Dict a b ~> * where
  Funny :: Dictionary {}dict

context :: DeBruijnContext Nat' dict -> LC sh Nat' -> LC sh Dictionary
context ctx (Var n) = Var undefined
-}

-- abstractly interpret
-- this should be parameterized by a monad!

--interp :: Monad m -> LC (context tr) -> m (LC (context tr))

-- Modeling Opetopes
-- here is Eric's editor: http://sma.epfl.ch/~finster/opetope/opetope.html
--
-- Note: Kock et al. use a similar scheme, where
--          - dots    <-->   lines
--          - spheres <-->   dots
--          - lines disappear
--          -                spheres appear

-- Note: In Eric's new work (at IAS) there are no
--       dots any more, instead he uses 'external cards', so
--          - (external) cards   <-->  lines
--          - space between stacked cards <--> external cards
--          - lines disappear
--          -                (regular) cards appear

import "../src/LangPrelude.prg" (maybeM)
import "../tests/Nat.prg"

##bounds backchain 10

-- GLOBAL TODOs
----------------

-- Naming: Seems essential for identifying things Hor(Name), Ver(Tree)
--         Name can be Label, then Niches (= sequences of opetope names).
--         the latter arise from the composition rule.
--         Note: don't store names in Stacks, that kills alpha
--               conversion. Instead names should be pushed into nodes
--               'singleton style' from outside: (node :: Tree (Hor `g))

-- Morphisms: given an opetope and a pointer to one of its cards
--            extract the opetope of that face (do we need a label
--            space to reliably find it?). This must be a type
--            function, with an algorithm accompanying it to extract
--            the face proper.

-- Composition: grafting of trees to external cards, but only if the
--              morphisms (faces) match. lower-dim stuff is unaffected.

-- Swapping: given a proof of equality between two niches, provide an
--           operation to swap them, replacing old faces by new ones,
--           FGL-style (functional graph library), just note that
--           certain morphisms are gone, others appeared.

-- References: a disciplined way of saying "I am an identical node to that guy",
--             by corollary these always obtain the same names.
--             a topologist would say 'surgery' (http://en.wikipedia.org/wiki/Surgery_theory)
--             We get a new Tree flavour, Ref, at least one up, followed by
--             naturals to index a node in a subtree.
--             At this point we are doing algebraic topology, and dealing with
--             closed manifolds, so that we can do homology etc. on them.
--             In logic this corresponds to relations, satisfiability.
--             NB.: It is not enough to make O cartesian. I also need
--                  a way to invoke specific inference rules from my logic.
--                  I must be able to parse a tree into a semantics, i.e.
--                  have binding stations, deBruijn/global references,
--                  punctuation, rule invocation etc. The key to all this
--                  are non-occupied "binding stations" which encode the
--                  additional linguistic stuff.

-- Quoting: So far we have only dealt with data, i.e. quoted (inert) syntax.
--          we need a way to convert this syntax to code (e.g. at some stage),
--          to obtain semantics. We can have the usual splicing game.
--          Lisp does this with sexprs and macros.
--          The code needs then be executed (run, decreasing stage), when
--          it becomes active, and we can observe the manifestation of its
--          semantics. The reduction system could go along the lines of the
--          (typed) LambdaGraph.

-- NbE: I fully believe we can use this technique to reduce opetopic terms
--      to normal form. ('many syntax', 'one semantics' adjunction:
--                       http://www.logicmatters.net/resources/pdfs/Galois.pdf)

-- Cartesian Closure: Creating 'lambda cards' by the above technology
--                    seems very ad-hoc and arbitrary. Contrast it with more
--                    serious attempts like higher-order containers
--                    (http://www.cs.nott.ac.uk/~txa/publ/hocont.pdf)
--                    or other ways to create internal languages.

-- TODO: these three must be LeftLists
--
kind Trees = NoTree | Pre (Tree d) Trees deriving syntax (ts) List(NoTree, Pre)

data ZoomCompley :: Tree e ~> Tree f ~> * where
  Nily :: ZoomCompley a a
  Consy :: Stack a b -> ZoomCompley b c -> ZoomCompley a c
 deriving List(cply)

data ZoomComplex :: Trees ~> * where
  Nilx :: ZoomComplex [()tr]ts
  Endx :: Stack a b -> ZoomComplex [a, b]ts
  Consx :: Stack a b -> ZoomComplex [b; c]ts -> ZoomComplex [a, b; c]ts
 deriving syntax (cplx) List(Nilx, Consx) Item(Endx)

data Dir :: *2 where
  Hor :: Dir
  Ver :: Dir

-- define the Tree kind, a rose tree
-- note: we may need a two-level kind, since we need to track disjointness
--       of subtrees
-- todo: later we may want to have a label kind parameter too

data Tree :: Dir ~> *1 where
  Unit :: Tree Ver
  Ni :: Tree Hor
  Fork :: Tree d ~> Tree Hor ~> Tree Hor
 deriving syntax (tr) List(Ni, Fork) Unit(Unit)

-- make it singleton

data Tree' :: Tree d ~> * where
  In :: Tree' ()tr
  Fork :: treelike head -> Tree' tail -> Tree' [head; tail]tr
  Done :: Tree' []tr
 deriving syntax (ar) List(Done, Fork) Unit(In) -- "arbre"
-- http://www.papoulipoesique.com/wp-content/uploads/2013/06/arbre.jpg

-- define a proposition for subtrees
-- to be checked: TakeHead must ensure that all the node is consumed

prop Subtree :: Tree d ~> Tree e ~> * where
  UnitSub :: Subtree ()tr tr
  BothNil :: Subtree []tr []tr
  TakeHead :: Subtree head head' -> Subtree tail tail' -> Subtree [head; tail]tr [head'; tail']tr

-- TODO: separate the notions of Niche / Frame / Cell
kind Volume = FramedHollow | FilledCell
kind Diagram = Closed Volume | OpenNiche
-- should be a parameter to Stack

-- now we can stack cards (these are zooms in Kock et al. parlance)

data Stack :: Tree d ~> Tree e ~> * where
  Corolla :: Corolla tr => Tree' tr -> Stack tr ()tr

  -- TODO: needed?
  --Expand :: (Subtree consumed tr, {nodeValence consumed} `Equal` {nodeValence tr}) => Stack consumed prod -> Stack tr prod

  -- add another target face to a web
  Target :: ({nodes tr} `Equal` {nodeValence out}) => Stack tr out -> Stack tr out

  -- the following three grab a node (and possibly its offsprings) and incorporate it into a single card
  NodeDone :: Stack []tr [()tr]tr
  Pick :: {- EntireNode => -} Stack head prodhead -> Stack tail prodtail -> Stack [head; tail]tr [prodhead; prodtail]tr
  Exclude :: {- EntireNode => -} Stack tail prod -> Stack [()tr; tail]tr prod
  -- TODO: maybe just specify a subtree (Tree') and that's it

  On :: (Subtree tr' tr, Pointers 1t at out) => Stack tr' out' -> Stack tr out -> Tree' at -> Stack tr {graft out' at out}

  -- building niches (pasting diagrams)
  -- TODO: these must produce a composite labelled Hor
  NicheDone :: Stack ()tr []tr
  Niche :: Stack tr out -> Stack tr [out]tr
  Also :: Pointers 1t at tr
       => Tree' at -> Stack tr' out' -> Stack tr out -> Stack {extgraft tr' at tr} [out'; out]tr

  -- put a frame around a niche
  Frame :: (Corolla out, {nodes tr}  `Equal` {nodeValence out}) => Stack tr out -> Stack tr out

 deriving syntax(z) Record(NicheDone, Also) Item(Target)

stop = ({}z)z

-- this is bogus, just make it compile again...
up :: Reference tr => Stack ()tr tr -> Stack ()tr [tr]tr
up inner = ({()ar=inner}z)z

-- it remains to define corollas

-- TODO: one could say {nodes tr} == 1
prop Corolla :: Tree d ~> * where
  None' :: Corolla []tr
  One' :: Corolla tail -> Corolla [()tr; tail]tr

--  o   --->  |
--  |         |

lolliCell :: Stack []tr ()tr
lolliCell = Corolla Done

--  |         |
--  o   --->  |
--  |         |

dolliCell :: Stack [()tr]tr ()tr
dolliCell = Corolla $ Fork In Done

--              |
--  [o]   --->  o
--   |          |

lolliFrame :: Stack []tr [()tr]tr
lolliFrame = Target NodeDone

--   |          |
--  [o]   --->  o
--   |          |

dolliFrame :: Stack [()tr]tr [()tr]tr
dolliFrame = Target (Exclude NodeDone)

--   |          |
--   |          o
-- [[o]]  --->  |
--   |          o
--   |          |

stacked :: Stack [()tr]tr [[()tr]tr]tr
stacked = (dolliFrame `On` dolliFrame) (In `Fork` Done)

--   |
--  [|]   --->  o
--   |          |

crossed :: Stack ()tr []tr
crossed = stop

-- we can now join things
--
dolliForever = [dolliFrame; dolliForever]cply
nopetope = [crossed, lolliFrame; dolliForever]cply

-- back to unit as fast as possible...
--
stopetope = [crossed, lolliFrame, dolliCell]cply
neverstopetope = [crossed, lolliFrame, dolliCell; neverstopetope]cply
stopetope' = [crossed, lolliFrame; (dolliCell)cplx]cplx
stopetope'' = [crossed, lolliFrame, dolliCell]cplx

--   |          o
-- [[|]]  --->  |
--   |          o
--   |          |

drossed :: Stack ()tr [[]tr]tr
drossed = up stop

-- ################################
-- ############  Niches ###########
-- ################################

--  |          +
--  |          |

-- this is a niche, but assume to be a frame
niche0 :: Stack ()tr []tr
niche0 = {}z

--  |           |
-- [|]          +
--  |           |

-- this is a niche, but assume to be a frame
niche1 :: Stack ()tr [[]tr]tr
niche1 = {()ar=stop; {}z}z

--  |         o   o
-- [|]  --->   \ /
-- [|]          +
--  |           |

-- this is a niche, but assume to be a frame
niche2 :: Stack ()tr [[]tr, []tr]tr
niche2 = {()ar=stop; niche1}z

--                |
--  |         o   o
-- [o]  --->   \ /
-- [|]          +
--  |           |

niche10 :: Stack [()tr]tr [[()tr]tr, []tr]tr
niche10 = {()ar=Exclude NodeDone; Niche stop}z

-- ################################
-- ############  Frames ###########
-- ################################

--   |              |
--  /|\         o   o
-- |[o]|  --->   \ /
-- |[|]|          o
--  \|/           |
--   |

cyclops :: Stack [()tr]tr [[()tr]tr, []tr]tr
cyclops = (niche10)z

-- Stacking, Valence, Affine subtree, Substitute at an affine position

-- counting Units in a tree

valence :: Tree d ~> Nat
{valence []tr} = 0t
{valence [head; tail]tr} = {plus {valence head} {valence tail}}
{valence ()tr} = 1t

-- counting siblings of a tree

nodeValence :: Tree d ~> Nat
{nodeValence []tr} = 0t
{nodeValence [head; tail]tr} = (1+{nodeValence tail})t

-- counting nodes in a tree

nodes :: Tree d ~> Nat
{nodes ()tr} = t
{nodes []tr} = 1t
{nodes [head; tail]tr} = {plus {nodes head} {nodes tail}}

-- nodeValenceAt: given a (multi)pointer, determine the node valences at those positions
--               WHERE     IN
nodeValenceAt :: Tree d ~> Tree e ~> Nat
{nodeValenceAt ()tr tree} = {nodeValence tree}
{nodeValenceAt []tr []tr} = 0t
{nodeValenceAt [head'; tail']tr [head; tail]tr} = {plus {nodeValenceAt head' head} {nodeValenceAt tail' tail}}

-- a pointer is a valence-1 subtree of a tree
-- it is used to mark a unit in a tree where substitution will occur
--
prop Pointers :: Nat ~> Tree d ~> Tree e ~> * where
  Finger :: Pointers 1t ()tr ()tr
  Finished :: Pointers 0t []tr []tr
  ThisWay :: Pointers 1t head' head -> Pointers n tail' tail -> Pointers (1+n)t [head'; tail']tr [head; tail]tr
  ElseWhere :: Pointers n tail' tail -> Pointers n [[]tr; tail']tr [head; tail]tr

-- http://en.wikipedia.org/wiki/Grafting
--
-- graft WHAT      WHERE     IN
graft :: Tree d ~> Tree e ~> Tree f ~> Tree f
{graft what ()tr ()tr} = what
{graft what []tr tr} = tr
{graft what [head'; tail']tr [head; tail]tr} = [{graft what head' head}; {graft what tail' tail}]tr

-- extgraft: extend and graft
--
extgraft :: Tree what ~> Tree wher ~> Tree tree ~> Tree tree'
{extgraft what ()tr ()tr} = what
{extgraft what []tr ()tr} = ()tr
{extgraft what [head; tail]tr ()tr} = {extgrafthor what [head; tail]tr}
{extgraft what []tr []tr} = []tr
{extgraft what []tr [head; tail]tr} = [head; tail]tr
{extgraft what [head'; tail']tr [head; tail]tr} = [{extgraft what head' head}; {extgraft what tail' tail}]tr

-- helper:
extgrafthor :: Tree what ~> Tree Hor ~> Tree Hor
{extgrafthor what []tr} = []tr
{extgrafthor what [head; tail]tr} = [{extgraft what head ()tr}; {extgrafthor what tail}]tr

{- NOTE: we have an Omega bug here:

prompt> :norm {graft []tr ()tr ()tr}
Normalizes to:
  []tr

prompt> :kind []tr
[]tr :: Tree Hor  = []tr

prompt> :kind {graft []tr ()tr ()tr}
{graft []tr ()tr ()tr} :: Tree Ver  = {graft []tr ()tr ()tr}

... BUT: Hor /= Ver :-(
-}

-- substitution: replace a pointed node (of valence n) in a tree with an
-- other tree of (valence n) -- TODO

-- HERE IS A NICE RESEARCH QUESTION:
-- is it possible to "proof search" a Zoom?
-- i.e.
{-

class ZoomLike (int :: Tree) (out :: Tree) where
  zoom :: (Nodes int ~ Valence out) => Zoom int out

-}

prop Reference :: Tree Hor ~> * where
  Stop :: Reference []tr
  Up :: Reference tr -> Reference [tr]tr
 deriving Nat(d) -- de Bruijn index

prop Teleport :: Tree Hor ~> * where
  Gate :: Teleport [()tr]tr
  Tele :: Teleport tr -> Teleport [tr]tr
 deriving Nat(sk) -- skips

{-

0
|   |
1   L  (lambda node)
|   |
2   1  (how many skips)
 \ /
  o
  |
  B  (binds here)
  |

Encodes \x.xx

-}

r2 = 2d
t1 = 1sk

lamX_XX = addBinder $ [r2, t1]ar

prop BindsUp :: Nat ~> Tree Hor ~> * where
  LastSkip :: BindsUp 1t [()tr]tr
  MoreSkip :: Teleport tr -> BindsUp n tr -> BindsUp (1+n)t [tr]tr
  -- prove Application node
  HeadBindsUp :: Nat' n -> BindsUp (1+n)t head -> BindsUp n [head; tail]tr
  TailBindsUp :: BindsUp n [head; tail]tr -> BindsUp n [nonempty, head; tail]tr

-- TODO: make sure that something teleports here
addBinder :: BindsUp 1t tr => Tree' tr -> Tree' [tr]tr
addBinder term = [term]ar

testB :: BindsUp 0t [[[[]tr]tr]tr,[()tr]tr]tr -> Tree' [[[[]tr]tr]tr,[()tr]tr]tr
testB ev = [r2, 0sk]ar
testB' = testB (TailBindsUp (HeadBindsUp 0v (LastSkip)))

testC :: BindsUp 0t [[[[[]tr]tr]tr,[[()tr]tr]tr]tr]tr -> Tree' [[[[[]tr]tr]tr,[[()tr]tr]tr]tr]tr
testC ev = lamX_XX
testC' = testC (HeadBindsUp 0v (TailBindsUp (HeadBindsUp 1v (MoreSkip 0sk LastSkip))))

--TODO: prop Lambda :: Tree Hor ~> * where

{-
The slogan is: binder nodes do not count as result nodes:
 - just consider the next node upstream
 - incoming (external) cards, when identified to a binder do not count as inputs to application
 - incoming (external) cards, when identified to an (iterated) application become pattern matching (sigma).

In the end all identifications have a semantics (hopefully!), when the counting rules are ensured.

-}

-- Now some fun stuff

data LC :: Shape ~> (k ~> *) ~> * where
  Var :: tf a -> LC (Rf a) tf
  App :: LC fsh tf -> LC ash tf -> LC (fsh `Ap` ash) tf
  Lam :: tf a -> LC sh tf -> LC (Lm sh) tf
  LetRec :: tf a -> LC ish tf -> LC esh tf -> LC ((Lm esh) `Ap` ish) tf
 deriving syntax (lc) Applicative(Var, App, Lam, LetRec)

alamX_XX = (\x->x x)lc

kind Dict key value = Dempty | Dextend (Dict key value) key value deriving LeftRecord(dict)

-- Contexts map keys to some value
--
data Context :: (key ~> *) ~> (value ~> *) ~> Dict key value ~> * where
  Empty :: Context key value {}dict
  Extend :: Context key value dict -> key k -> value v -> Context key value {dict; k = v}dict
 deriving LeftRecord(ctx)

-- DeBruijn levels as keys
--
dictSize :: Dict key value ~> Nat
{dictSize {}dict} = 0t
{dictSize {pre; k = v}dict} = (1+{dictSize pre})t

data DeBruijnContext :: (value ~> *) ~> Dict Nat value ~> * where
  DeBruijnEmpty :: DeBruijnContext value {}dict
  DeBruijnExtend :: DeBruijnContext value dict -> value v -> DeBruijnContext value {dict; {dictSize dict} = v}dict
 deriving LeftList(dtx)

getDeBruijnIndex :: Dict key value ~> value ~> Nat ~> Nat
{getDeBruijnIndex {pre; k = v}dict v acc} = acc
{getDeBruijnIndex {pre; k = v'}dict v acc} = {getDeBruijnIndex pre v (1+acc)t}

lookUpDeBruijn :: DeBruijnContext Label dict -> Label l -> Nat' acc -> Maybe (Nat' {getDeBruijnIndex dict l acc})
lookUpDeBruijn []dtx _ _ = Nothing
lookUpDeBruijn [pre; known]dtx lab acc = case sameLabel known lab of
                                         R _ -> lookUpDeBruijn pre lab (1+acc)t
                                         L Eq -> Just acc

monad maybeM

l2n :: Shape ~> Shape
{l2n (Lm sh)} = Lm {l2n sh}
{l2n (Ap f a)} = Ap {l2n f} {l2n a}
{l2n (Rf t)} = Rf n -- getDeBruijnIndex!!! FIXME

toDeBruijn :: DeBruijnContext Label dict -> LC sh Label -> Maybe (LC {l2n sh} Nat')
toDeBruijn ctx (Var a) = do idx <- lookUpDeBruijn ctx a 0t
                            return $ Var idx
toDeBruijn ctx (Lam l a) = do a' <- toDeBruijn [ctx; l]dtx a
                              return $ Lam 0t a'
toDeBruijn ctx (App f a) = do f' <- toDeBruijn ctx f
                              a' <- toDeBruijn ctx a
                              return $ App f' a'

-- we should get a pair (Nat, Context) -- TODO
-- this is not good yet!
--
{-
toFullContext :: DeBruijnContext Nat' dict -> Shape' sh -> LC sh Nat' -> LC sh (Context Nat' Shape')
toFullContext ctx (Rf a') (Var a) = Var ctx
toFullContext ctx sh (Lam l a) = Lam ctx $ toFullContext [ctx; l]dtx a
toFullContext ctx sh (App f a) = App (toFullContext ctx f) (toFullContext ctx a)
-}

-- Let :: tf a -> LC tf -> LC tf -> LC tf -- not needed!
pattern Let n v exp = App (Lam n exp) v

-- fun with church encoding

true = (\t->\f->t)lc
--false = (\t f->f)lc -- BUG!
false = (\t->\f->f)lc

-- church 'if'
chif = (\v->\iftrue->\iffalse->v iftrue iffalse)lc

chtest = (chif true false true)lc -- will not do what you expect
--chtest' = ($chif $true $false $true)lc -- not ready yet!

chtest'' = (let { true = \t->\f->t
                ; false = \t->\f->f
                ; chif = \v->\iftrue->\iffalse -> v iftrue iffalse
                }
            in chif true false true)lc -- this still does not work :-(

letrecToLet :: LC sh k -> LC sh k
letrecToLet (App f a) = App (letrecToLet f) (letrecToLet a)
letrecToLet (v@Var _) = v
letrecToLet (l@Lam _ _) = l
letrecToLet (LetRec n v e) = App (Lam n e) v -- Let n v e -- Omega pattern bug???

l2l = letrecToLet (let a = a in a)lc

-- shapes

kind Shape = Lm Shape | Ap Shape Shape | Rf k

data Shape' :: Shape ~> * where
  Ref :: Nat' n -> Shape' (Rf n)
  Nam :: Label n -> Shape' (Rf n)
  Lm :: Shape' inner -> Shape' (Lm inner)
  Ap :: Shape' f -> Shape' a -> Shape' (f `Ap` a)

shape :: LC sh Nat' -> Shape' sh
shape (Var n) = Ref n
shape (Lam n e) = Lm $ shape e
shape (App f a) = shape f `Ap` shape a

{-
data Dictionary :: Dict a b ~> * where
  Funny :: Dictionary {}dict

context :: DeBruijnContext Nat' dict -> LC sh Nat' -> LC sh Dictionary
context ctx (Var n) = Var undefined
-}

-- abstractly interpret
-- this should be parameterized by a monad!

--interp :: Monad m -> LC (context tr) -> m (LC (context tr))


codegen/QtWinExtras/QWinJumpListCategory.prg: fixed

Modified:
codegen/QtWinExtras/QWinJumpListCategory.prg

$header

#include "hbclass.ch"

#ifndef QT5XHB_NO_REQUESTS
REQUEST QWINJUMPLISTITEM
#endif

CLASS QWinJumpListCategory

   DATA pointer
   DATA self_destruction INIT .F.

   METHOD new
   METHOD delete
   METHOD type
   METHOD isVisible
   METHOD setVisible
   METHOD title
   METHOD setTitle
   METHOD count
   METHOD isEmpty
   METHOD items
   METHOD addItem
   METHOD addDestination
   METHOD addLink
   METHOD addSeparator
   METHOD clear

   METHOD newFrom
   METHOD newFromObject
   METHOD newFromPointer
   METHOD selfDestruction
   METHOD setSelfDestruction

   DESTRUCTOR destroyObject

END CLASS

$destructor

#pragma BEGINDUMP

$includes=5,2,0

/*
explicit QWinJumpListCategory(const QString &title = QString())
*/
$constructor=5,2,0|new|const QString &=QString()

$deleteMethod=5,2,0

/*
Type type() const
*/
$method=5,2,0|QWinJumpListCategory::Type|type|

/*
bool isVisible() const
*/
$method=5,2,0|bool|isVisible|

/*
void setVisible(bool visible)
*/
$method=5,2,0|void|setVisible|bool

/*
QString title() const
*/
$method=5,2,0|QString|title|

/*
void setTitle(const QString &title)
*/
$method=5,2,0|void|setTitle|const QString &

/*
int count() const
*/
$method=5,2,0|int|count|

/*
bool isEmpty() const
*/
$method=5,2,0|bool|isEmpty|

/*
QList<QWinJumpListItem *> items() const
*/
$method=5,2,0|QList<QWinJumpListItem *>|items|

/*
void addItem(QWinJumpListItem *item)
*/
$method=5,2,0|void|addItem|QWinJumpListItem *

/*
QWinJumpListItem *addDestination(const QString &filePath)
*/
$method=5,2,0|QWinJumpListItem *|addDestination|const QString &

/*
QWinJumpListItem *addLink(const QString &title, const QString &executablePath, const QStringList &arguments = QStringList())
*/
$internalMethod=5,2,0|QWinJumpListItem *|addLink,addLink1|const QString &,const QString &,const QStringList &=QStringList()

/*
QWinJumpListItem *addLink(const QIcon &icon, const QString &title, const QString &executablePath, const QStringList &arguments = QStringList())
*/
$internalMethod=5,2,0|QWinJumpListItem *|addLink,addLink2|const QIcon &,const QString &,const QString &,const QStringList &=QStringList()

//[1]QWinJumpListItem *addLink(const QString &title, const QString &executablePath, const QStringList &arguments = QStringList())
//[2]QWinJumpListItem *addLink(const QIcon &icon, const QString &title, const QString &executablePath, const QStringList &arguments = QStringList())

HB_FUNC_STATIC( QWINJUMPLISTCATEGORY_ADDLINK )
{
  if( ISBETWEEN(2,3) && ISCHAR(1) && ISCHAR(2) && ISOPTARRAY(3) )
  {
    QWinJumpListCategory_addLink1();
  }
  else if( ISBETWEEN(3,4) && ISQICON(1) && ISCHAR(2) && ISCHAR(3) && ISOPTARRAY(4) )
  {
    QWinJumpListCategory_addLink2();
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
}

/*
QWinJumpListItem *addSeparator()
*/
$method=5,2,0|QWinJumpListItem *|addSeparator|

/*
void clear()
*/
$method=5,2,0|void|clear|

$extraMethods

#pragma ENDDUMP

$header

#include "hbclass.ch"

#ifndef QT5XHB_NO_REQUESTS
REQUEST QWINJUMPLISTITEM
#endif

CLASS QWinJumpListCategory

   DATA pointer
   DATA self_destruction INIT .F.

   METHOD new
   METHOD delete
   METHOD type
   METHOD isVisible
   METHOD setVisible
   METHOD title
   METHOD setTitle
   METHOD count
   METHOD isEmpty
   METHOD items
   METHOD addItem
   METHOD addDestination
   METHOD addLink
   METHOD addSeparator
   METHOD clear

   METHOD newFrom
   METHOD newFromObject
   METHOD newFromPointer
   METHOD selfDestruction
   METHOD setSelfDestruction

   DESTRUCTOR destroyObject

END CLASS

$destructor

#pragma BEGINDUMP

$includes=5,2,0

/*
explicit QWinJumpListCategory(const QString &title = QString())
*/
$constructor=5,2,0|new|const QString &=QString()

$deleteMethod=5,2,0

/*
Type type() const
*/
$method=5,2,0|Type|type|

/*
bool isVisible() const
*/
$method=5,2,0|bool|isVisible|

/*
void setVisible(bool visible)
*/
$method=5,2,0|void|setVisible|bool

/*
QString title() const
*/
$method=5,2,0|QString|title|

/*
void setTitle(const QString &title)
*/
$method=5,2,0|void|setTitle|const QString &

/*
int count() const
*/
$method=5,2,0|int|count|

/*
bool isEmpty() const
*/
$method=5,2,0|bool|isEmpty|

/*
QList<QWinJumpListItem *> items() const
*/
$method=5,2,0|QList<QWinJumpListItem *>|items|

/*
void addItem(QWinJumpListItem *item)
*/
$method=5,2,0|void|addItem|QWinJumpListItem *

/*
QWinJumpListItem *addDestination(const QString &filePath)
*/
$method=5,2,0|QWinJumpListItem *|addDestination|const QString &

/*
QWinJumpListItem *addLink(const QString &title, const QString &executablePath, const QStringList &arguments = QStringList())
*/
$internalMethod=5,2,0|QWinJumpListItem *|addLink,addLink1|const QString &,const QString &,const QStringList &=QStringList()

/*
QWinJumpListItem *addLink(const QIcon &icon, const QString &title, const QString &executablePath, const QStringList &arguments = QStringList())
*/
$internalMethod=5,2,0|QWinJumpListItem *|addLink,addLink2|const QIcon &,const QString &,const QString &,const QStringList &=QStringList()

//[1]QWinJumpListItem *addLink(const QString &title, const QString &executablePath, const QStringList &arguments = QStringList())
//[2]QWinJumpListItem *addLink(const QIcon &icon, const QString &title, const QString &executablePath, const QStringList &arguments = QStringList())

HB_FUNC_STATIC( QWINJUMPLISTCATEGORY_ADDLINK )
{
  if( ISBETWEEN(2,3) && ISCHAR(1) && ISCHAR(2) && ISOPTARRAY(3) )
  {
    QWinJumpListCategory_addLink1();
  }
  else if( ISBETWEEN(3,4) && ISQICON(1) && ISCHAR(2) && ISCHAR(3) && ISOPTARRAY(4) )
  {
    QWinJumpListCategory_addLink2();
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
}

/*
QWinJumpListItem *addSeparator()
*/
$method=5,2,0|QWinJumpListItem *|addSeparator|

/*
void clear()
*/
$method=5,2,0|void|clear|

$extraMethods

#pragma ENDDUMP


construct works!

construct works!

import "../src/LangPrelude.prg"

data TwoBits = OO | OI | IO | II

data Mark = FullStop | Stop TwoBits | Digit TwoBits

data Way = Arrived | Step Mark Way deriving List(w)

etalon = "qrs101qrs30qrs13qrs3rsS"
-- acc:   55555544455444443332221

w1 = [FullStop]w
w2 = [Stop OI, FullStop]w
w3 = [Stop IO, Stop OI, FullStop]w
w4 = [Digit II, Stop IO, Stop OI, FullStop]w
w5 = [Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w6 = [Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w7 = [Stop II, Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w9 = [Digit OI, Digit II, Stop II, Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w12 = [Stop II, Stop IO, Stop OI, Digit OI, Digit II, Stop II, Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w13 = [Digit OO, Stop II, Stop IO, Stop OI, Digit OI, Digit II, Stop II, Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w14 = [Digit II, Digit OO, Stop II, Stop IO, Stop OI, Digit OI, Digit II, Stop II, Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w15 = [Stop OI, Digit II, Digit OO, Stop II, Stop IO, Stop OI, Digit OI, Digit II, Stop II, Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w

countSteps (way@[_;_]w) = howmanysteps 0 way

howmanysteps :: Int -> Way -> Int
howmanysteps 0 []w = 0
howmanysteps corr [FullStop]w = corr + 1
howmanysteps corr [Stop OI; way]w = pickupMarks (corr + 1) way 0
howmanysteps corr [Stop IO, Stop OI; way]w = pickupMarks (corr + 2) way 0
howmanysteps corr [Stop II, Stop IO, Stop OI; way]w = pickupMarks (corr + 3) way 0
howmanysteps corr [Digit _,_,_; more]w = howmanysteps (corr + 3) more

pickupMarks corr [FullStop]w acc = corr + 1
pickupMarks corr [Stop _; _]w acc = corr + acc
pickupMarks corr [Digit OO; more]w acc = pickupMarks (corr + 1) more $ 4 * acc
pickupMarks corr [Digit OI; more]w acc = pickupMarks (corr + 1) more $ 4 * acc + 1
pickupMarks corr [Digit IO; more]w acc = pickupMarks (corr + 1) more $ 4 * acc + 2
pickupMarks corr [Digit II; more]w acc = pickupMarks (corr + 1) more $ 4 * acc + 3

l2w = foldr (Step . c2m) Arrived
  where c2m 'S' = FullStop
        c2m 's' = Stop OI
        c2m 'r' = Stop IO
        c2m 'q' = Stop II
        c2m '0' = Digit OO
        c2m '1' = Digit OI
        c2m '2' = Digit IO
        c2m '3' = Digit II

foldw :: (Mark -> b -> b) -> b -> Way -> b
foldw _ b []w = b
foldw f b [m; ms]w = f m $ foldw f b ms

w2l = foldw ((:) . m2c) []
  where m2c FullStop = 'S'
        m2c (Stop OI) = 's'
        m2c (Stop IO) = 'r'
        m2c (Stop II) = 'q'
        m2c (Digit OO) = '0'
        m2c (Digit OI) = '1'
        m2c (Digit IO) = '2'
        m2c (Digit II) = '3'

waylen = foldw (\_ n->n+1) 0

etalon' = l2w etalon

countAlongTheWay = foldw tupled [(0,[]w)]
  where tupled m (l@[(_,w);_]) = (countSteps [m;w]w,[m;w]w) : l

prepend :: Int -> Way -> Way
prepend 0 acc = acc
prepend n acc | n `mod` 4 == 0 = prepend (n `div` 4) [Digit OO; acc]w
prepend n acc | n `mod` 4 == 1 = prepend (n `div` 4) [Digit OI; acc]w
prepend n acc | n `mod` 4 == 2 = prepend (n `div` 4) [Digit IO; acc]w
prepend n acc | n `mod` 4 == 3 = prepend (n `div` 4) [Digit II; acc]w

-- builds a way of length at least 'min'
-- maintains the invariant, that the way starts with 'Stop II'
--
construct :: Int -> Way -> Way
construct min (acc@[Stop II; _]w) = if l < min
                                    then construct min $ [Stop II, Stop IO, Stop OI; prepend l acc]w
                                    else acc
  where l = waylen acc

import "../src/LangPrelude.prg"

data TwoBits = OO | OI | IO | II

data Mark = FullStop | Stop TwoBits | Digit TwoBits

data Way = Arrived | Step Mark Way deriving List(w)

etalon = "qrs101qrs30qrs13qrs3rsS"
-- acc:   55555544455444443332221

w1 = [FullStop]w
w2 = [Stop OI, FullStop]w
w3 = [Stop IO, Stop OI, FullStop]w
w4 = [Digit II, Stop IO, Stop OI, FullStop]w
w5 = [Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w6 = [Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w7 = [Stop II, Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w9 = [Digit OI, Digit II, Stop II, Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w12 = [Stop II, Stop IO, Stop OI, Digit OI, Digit II, Stop II, Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w13 = [Digit OO, Stop II, Stop IO, Stop OI, Digit OI, Digit II, Stop II, Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w14 = [Digit II, Digit OO, Stop II, Stop IO, Stop OI, Digit OI, Digit II, Stop II, Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w
w15 = [Stop OI, Digit II, Digit OO, Stop II, Stop IO, Stop OI, Digit OI, Digit II, Stop II, Stop IO, Stop OI, Digit II, Stop IO, Stop OI, FullStop]w

countSteps (way@[_;_]w) = howmanysteps 0 way

howmanysteps :: Int -> Way -> Int
howmanysteps 0 []w = 0
howmanysteps corr [FullStop]w = corr + 1
howmanysteps corr [Stop OI; way]w = pickupMarks (corr + 1) way 0
howmanysteps corr [Stop IO, Stop OI; way]w = pickupMarks (corr + 2) way 0
howmanysteps corr [Stop II, Stop IO, Stop OI; way]w = pickupMarks (corr + 3) way 0
howmanysteps corr [Digit _,_,_; more]w = howmanysteps (corr + 3) more

pickupMarks corr [FullStop]w acc = corr + 1
pickupMarks corr [Stop _; _]w acc = corr + acc
pickupMarks corr [Digit OO; more]w acc = pickupMarks (corr + 1) more $ 4 * acc
pickupMarks corr [Digit OI; more]w acc = pickupMarks (corr + 1) more $ 4 * acc + 1
pickupMarks corr [Digit IO; more]w acc = pickupMarks (corr + 1) more $ 4 * acc + 2
pickupMarks corr [Digit II; more]w acc = pickupMarks (corr + 1) more $ 4 * acc + 3

l2w = foldr (Step . c2m) Arrived
  where c2m 'S' = FullStop
        c2m 's' = Stop OI
        c2m 'r' = Stop IO
        c2m 'q' = Stop II
        c2m '0' = Digit OO
        c2m '1' = Digit OI
        c2m '2' = Digit IO
        c2m '3' = Digit II

foldw :: (Mark -> b -> b) -> b -> Way -> b
foldw _ b []w = b
foldw f b [m; ms]w = f m $ foldw f b ms

w2l = foldw ((:) . m2c) []
  where m2c FullStop = 'S'
        m2c (Stop OI) = 's'
        m2c (Stop IO) = 'r'
        m2c (Stop II) = 'q'
        m2c (Digit OO) = '0'
        m2c (Digit OI) = '1'
        m2c (Digit IO) = '2'
        m2c (Digit II) = '3'

etalon' = l2w etalon

countAlongTheWay = foldw tupled [(0,[]w)]
  where tupled m (l@[(_,w);_]) = (countSteps [m;w]w,[m;w]w) : l

prepend :: Int -> Way -> Way
prepend 0 acc = acc
prepend n acc | n `mod` 4 == 0 = prepend (n `div` 4) [Digit OO; acc]w
prepend n acc | n `mod` 4 == 1 = prepend (n `div` 4) [Digit OI; acc]w
prepend n acc | n `mod` 4 == 2 = prepend (n `div` 4) [Digit IO; acc]w
prepend n acc | n `mod` 4 == 3 = prepend (n `div` 4) [Digit II; acc]w


[Runtime tests] Adjusted and enhanced tests

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//
USING System
USING System.Collections.Generic
USING System.Linq
USING System.Text
USING XUnit

#pragma warnings(165, off)  // unassigned variables
#pragma warnings(219, off)  // assigned but not used

// Array tests are not working correctly yet with the current build
BEGIN NAMESPACE XSharp.VO.Tests

	CLASS StringTests

		[Fact, Trait("Category", "String")];
		METHOD MoreStringTests() AS VOID
			Assert.Equal("          ", Transform("", "@R XXXXXXXXXX")        )
			Assert.Equal("Italia    ", Transform("Italia", "@R XXXXXXXXXX")  )
			Assert.Equal("ITALIA    ", Transform("Italia", "@! XXXXXXXXXX")  )
			Assert.Equal("Italia    ", Transform("Italia", "XXXXXXXXXX")     )
			Assert.Equal("1234512345", Transform("1234512345", "XXXXXXXXXX") )
			Assert.Equal("1234"      , Transform("1234", "XX99") )
			Assert.Equal("ITALIA"    , Transform("Italia", "@!") )

			LOCAL c AS STRING
			c := "Not nil!"
			Assert.False(c == NIL)
			Assert.True(c != NIL)
			LOCAL u AS STRING
			u := "Not nil!"
			Assert.False(c == NIL)
			Assert.True(c != NIL)
		RETURN

		[Fact, Trait("Category", "StringEq")];
		METHOD StringEquality() AS VOID
			LOCAL c1,c2 AS STRING
			LOCAL u1,u2 AS USUAL
			LOCAL exact AS LOGIC
			u1 := c1 := "TESTLONG"
			u2 := c2 := "TEST"
			exact := SetExact( FALSE )

			Assert.Equal(TRUE, c1 = c2)
			Assert.Equal(TRUE, c1 != c2)

			Assert.Equal(TRUE, u1 = u2)
			Assert.Equal(FALSE, u1 != u2)

			SetExact( exact )
		RETURN

		[Fact, Trait("Category", "Str")];
		METHOD StrTests() AS VOID
			LOCAL deci,thou,digit,decimal,fixed_,digitfixed AS USUAL
			deci := SetDecimalSep(Asc("."))
			thou := SetThousandSep(Asc(","))
			digit := SetDigit(6)
			decimal := SetDecimal(3)
			fixed_ := SetFixed(FALSE)
			digitfixed := SetDigitFixed(FALSE)

			Assert.Equal( "     1.2"			, Str(1.2) )
			Assert.Equal( "    12.3"			, Str(12.3) )
			Assert.Equal( "    12.34"			, Str(12.34) )
			Assert.Equal( "   123.456"			, Str(123.456) )
			Assert.Equal( "  1234.567"			, Str(1234.567) )
			Assert.Equal( "  1234.5678"			, Str(1234.5678) )
			Assert.Equal( "  1234.5679012345"	, Str(1234.5679012345) )
			Assert.Equal( "123456.78901234568"	, Str(123456.78901234567) )
			Assert.Equal( "999999" , Str(999999) )
			Assert.Equal( "******" , Str(1000000) )

			Assert.Equal( "0.0" , Transform(0 , "9.9") )
			Assert.Equal( "1.0" , Transform(1 , "9.9") )
			Assert.Equal( "*.*" , Transform(-1 , "9.9") )
			SetDecimalSep(Asc(","))
			SetThousandSep(Asc("."))
			Assert.Equal( " 0,00" , Transform(0 , "99.99") )
			Assert.Equal( " 1,00" , Transform(1 , "99.99") )
			Assert.Equal( "-1,00" , Transform(-1 , "99.99") )

			Assert.Equal( "  0,00" , Transform(0 , "999.99") )
			Assert.Equal( "  0,0" , Transform(0 , "999.9") )
			Assert.Equal( " 0,0" , Transform(0 , "99.9") )

			SetFixed(TRUE)
			SetDigit(5)
			Assert.Equal("  123" , Str(123))
			Assert.Equal("123" , Str(123 , -1))
			Assert.Equal("123" , Str(123 , 3))
			Assert.Equal("-123" , Str(-123 , 4))
			Assert.Equal("-123" , Str(-123 , -1))
			Assert.Equal(" -123" , Str(-123))
			Assert.Equal(" 123" , Str(123 , 4))
			Assert.Equal("**" , Str(123 , 2))
			SetDigit(10)
			Assert.Equal(" 123456789" , Str(123456789))
			Assert.Equal("**********" , Str(12345678901))

			SetFixed(FALSE)
			SetDigit(5)
			Assert.Equal("  123" , Str(123))
			Assert.Equal("123" , Str(123 , -1))
			Assert.Equal("123" , Str(123 , 3))
			Assert.Equal("-123" , Str(-123 , 4))
			Assert.Equal("-123" , Str(-123 , -1))
			Assert.Equal(" -123" , Str(-123))
			Assert.Equal(" 123" , Str(123 , 4))
			Assert.Equal("**" , Str(123 , 2))
			SetDigit(10)
			Assert.Equal(" 123456789" , Str(123456789))
			Assert.Equal("**********" , Str(12345678901))

			SetDecimal(2)
			SetDecimalSep(Asc(","))
			SetThousandSep(Asc("."))
			Assert.Equal( "**",    Str(1.23 , 2 , 1) )
			Assert.Equal( "1,2",   Str(1.2 , 3) )
			Assert.Equal( "123",   Str(123.456 , 3) )

			Assert.Equal( "123",   Str(123.4567 , 3 , 1) )
			Assert.Equal( "123,",  Str(123.4567 , 4 , 2) )
			Assert.Equal( "123,4", Str(123.4567 , 5 , 3) )
			Assert.Equal( "****" , Str(123.4567 , 4 , 3) )
			Assert.Equal( "*****", Str(123.4567 , 5 , 4) )

			Assert.Equal( "***",   Str(-123.4567 , 3 , 1) )
			Assert.Equal( "-123",  Str(-123.4567 , 4 , 2) )
			Assert.Equal( "-123,", Str(-123.4567 , 5 , 3) )
			Assert.Equal( "****" , Str(-123.4567 , 4 , 3) )
			Assert.Equal( "*****", Str(-123.4567 , 5 , 4) )

			Assert.Equal( "0,0",   Str(0.0 , -1) )
			Assert.Equal( "0,1",   Str(0.1 , -1) )
			Assert.Equal( "-0,1",  Str(-0.1 , -1) )
			Assert.Equal( "0,000",   Str(0.0 , -1 , 3) )
			Assert.Equal( "0,100",   Str(0.1 , -1 , 3) )
			Assert.Equal( "-0,100",  Str(-0.1 , -1 , 3) )

			Assert.Equal( "  123"	, Str(FloatFormat(123 , 5, 0)) )
			Assert.Equal( "   123"	, Str(FloatFormat(123 , 6, 0)) )
			Assert.Equal( " 123,5"	, Str(FloatFormat(123.456 , 6, 1) ) )
			Assert.Equal( "123,46"	, Str(FloatFormat(123.456 , 6, 2) ) )
			Assert.Equal( " 123,46"	, Str(FloatFormat(123.456 , 7, 2) ) )

			SetDecimalSep(deci)
			SetThousandSep(thou)
			SetDigit(digit)
			SetDecimal(decimal)
			SetFixed(fixed_)
			SetDigitFixed(digitfixed)
		RETURN

		[Fact, Trait("Category", "Str")];
		METHOD Str_With_SetFixed_TRUE() AS VOID

		   SetDecimalSep(Asc("."))
		   SetThousandSep(Asc(","))
		   SetDecimal(3)
		   SetDigit(12)

		   SetFixed(TRUE)
		   SetDigitFixed(TRUE)

		   Assert.Equal( Str(12.34)            		, "          12.340")
		   Assert.Equal( Str1(12.34)          		, "          12.340")
		   Assert.Equal( Str(123.456)         		, "         123.456")
		   Assert.Equal( Str1(123.456)       		, "         123.456")
		   Assert.Equal( Str(1230.4567)         	, "        1230.457")
		   Assert.Equal( Str1(1230.4567)        	, "        1230.457")
		   Assert.Equal( Str(100000001234.4567)		, "100000001234.457")
		   Assert.Equal( Str1(100000001234.4567)	, "100000001234.457")
		   Assert.Equal( Str(1000000001234.4567)	, "****************")
		   Assert.True ( Str1(1000000001234.4567):StartsWith("********"))
		   Assert.Equal( Str(12.3)              	, "          12.300")
		   Assert.Equal( Str1(12.3)            		, "          12.300")
		   Assert.Equal( Str(12.34567)        	 	, "          12.346")
		   Assert.Equal( Str1(12.34567)        		, "          12.346")
		   Assert.Equal( Str(12.34 , 10, 2)    		, "     12.34")
		   Assert.Equal( Str(12.34 , 5, 2)     		, "12.34")
		   Assert.Equal( Str(12.34 , 4, 2)     		, "12.3")
		   Assert.Equal( Str(12.34 , 4, 1)     		, "12.3")
		   Assert.Equal( Str(12.34 , 2, 1)     		, "**")
		   Assert.Equal( Str3(12.34 , 10, 2)   		, "     12.34")
		   Assert.Equal( Str3(12.34 , 5, 2)    		, "12.34")
		   Assert.Equal( Str3(12.34 , 4, 2)     	, "12.3")
		   Assert.Equal( Str3(12.34 , 4, 1)     	, "12.3")
		   Assert.Equal( Str3(12.34 , 2, 1)    		, "**")
		   Assert.Equal( Str(-12.34)            	, "         -12.340")
		   Assert.Equal( Str1(-12.34)           	, "         -12.340")
		   Assert.Equal( Str(-12.3456)         		, "         -12.346")
		   Assert.Equal( Str1(-12.3456)         	, "         -12.346")
		   Assert.Equal( Str(-12.34 , 10, 2)    	, "    -12.34")
		   Assert.Equal( Str(-12.34 , 5, 2)     	, "-12.3")	 //VO wrong: -2.34
		   Assert.Equal( Str(-12.34 , 4, 2)     	, "-12.")    // VO wrong: -12.
		   Assert.Equal( Str(-12.34 , 4, 1)     	, "-12.")    //VO wrong: -2.3
	       Assert.Equal( Str(-12.34 , 4, 0)     	, " -12")    //VO wrong: -2.3
		   Assert.Equal( Str(-12.34 , 2, 1)     	, "**")

		   SetDigit(8)
		   SetDecimal(2)
		   SetDecimalSep(Asc(","))
		   SetThousandSep(Asc("."))

		   Assert.Equal( Str(123456789.1)	, "***********")
		   Assert.True(Str1(123456789.1):StartsWith("*****"))
		   Assert.Equal( Str(12345678.1)	, "12345678,10")
		   Assert.Equal(Str1(12345678.1)	, "12345678,10")
		   Assert.Equal( Str(1234567.1)		, " 1234567,10")
		   Assert.Equal(Str1(1234567.1)		, " 1234567,10")
		   Assert.Equal( Str(123456.1)		, "  123456,10")
		   Assert.Equal(Str1(123456.1)		, "  123456,10")

		RETURN

		[Fact, Trait("Category", "Str")];
		METHOD Str_With_SetFixed_FALSE() AS VOID

		   SetDecimalSep(Asc("."))
		   SetThousandSep(Asc(","))
		   SetDecimal(3)
		   SetDigit(12)

		   SetFixed(FALSE)
		   SetDigitFixed(FALSE)

		   Assert.Equal( Str(12.34)            		, "          12.34")
		   Assert.Equal( Str1(12.34)          		, "          12.34")
		   Assert.Equal( Str(123.456)         		, "         123.456")
		   Assert.Equal( Str1(123.456)				, "         123.456")
		   Assert.Equal( Str(1230.4567)         	, "        1230.4567")
		   Assert.Equal( Str1(1230.4567)        	, "        1230.4567")
		   Assert.Equal( Str(100000001234.4567)		, "100000001234.4567")
		   Assert.Equal( Str1(100000001234.4567)	, "100000001234.4567")
		   Assert.Equal( Str(1000000001234.4567)	, "*****************")
//		   Assert.Equal( Str1(1000000001234.4567)	, "*****************")
		   Assert.True(  Str1(1000000001234.4567):StartsWith("*")) // it's really impossible to replicate completely VO's insane behavior
		   Assert.Equal( Str(12.3)              	, "          12.3")
		   Assert.Equal( Str1(12.3)            		, "          12.3")
		   Assert.Equal( Str(12.34567)         		, "          12.34567")
		   Assert.Equal( Str1(12.34567)        		, "          12.34567")
		   Assert.Equal( Str(12.34 , 10, 2)    		, "     12.34")
		   Assert.Equal( Str(12.34 , 5, 2)     		, "12.34")
		   Assert.Equal( Str(12.34 , 4, 2)     		, "12.3") // VO returns 12.3
		   Assert.Equal( Str(12.34 , 4, 1)     		, "12.3")
		   Assert.Equal( Str(12.34 , 2, 1)     		, "**")
		   Assert.Equal( Str3(12.34 , 10, 2)   		, "     12.34")
		   Assert.Equal( Str3(12.34 , 5, 2)    		, "12.34")
		   Assert.Equal( Str3(12.34 , 4, 2)     	, "12.3")   // VO 12.3
		   Assert.Equal( Str3(12.34 , 4, 1)     	, "12.3")
		   Assert.Equal( Str3(12.34 , 2, 1)    		, "**")
		   Assert.Equal( Str(-12.34)            	, "         -12.34")
		   Assert.Equal( Str1(-12.34)           	, "         -12.34")
		   Assert.Equal( Str(-12.3456)         		, "         -12.3456")
		   Assert.Equal( Str1(-12.3456)         	, "         -12.3456")
		   Assert.Equal( Str(-12.34 , 10, 2)    	, "    -12.34")
		   Assert.Equal( Str(-12.34 , 5, 2)     	, "-12.3")	 //VO: -2.34
		   Assert.Equal( Str(-12.34 , 4, 2)     	, "-12.")    // VO
		   Assert.Equal( Str(-12.34 , 4, 1)     	, "-12.")    //VO: -2.3
		   Assert.Equal( Str(-12.34 , 2, 1)     	, "**")

		   SetDigit(8)
		   SetDecimal(2)

		   Assert.True( Str(123456789.1):StartsWith("*"))
		   Assert.True(Str1(123456789.1):StartsWith("*"))

		   Assert.Equal( "12.34" , Str(12.34 , -1))
		   Assert.Equal( "12.3400" , Str(12.34 , -1 , 4))
		   Assert.Equal( "1.1" , Str(1.1 , -1 , 1))

            [Fact, Trait("Category", "Str")];
		    METHOD Pad_Test() AS VOID
                LOCAL u AS USUAL
                Assert.Equal(Space(10), PadR(u,10))
                Assert.Equal(Space(10), Pad(u,10))
                Assert.Equal(Space(10), PadC(u,10))
                Assert.Equal(Space(10), PadL(u,10))
                u := "a"
                Assert.Equal("a         ", PadR(u,10))
                Assert.Equal("a         ", Pad(u,10))
                Assert.Equal("    a     ", PadC(u,10))
                Assert.Equal("----a-----", PadC(u,10,"-"))
                Assert.Equal("         a", PadL(u,10))
                u := 1
                Assert.Equal("1         ", PadR(u,10))
                Assert.Equal("1         ", Pad(u,10))
                Assert.Equal("    1     ", PadC(u,10))
                Assert.Equal("====1=====", PadC(u,10,"="))
                Assert.Equal("         1", PadL(u,10))
                u := 1.23
                SetDecimalSep(Asc("."))
                Assert.Equal("1.23      ", PadR(u,10))
                Assert.Equal("1.23      ", Pad(u,10))
                Assert.Equal("   1.23   ", PadC(u,10))
                Assert.Equal("...1.23...", PadC(u,10,"."))
                Assert.Equal("      1.23", PadL(u,10))

#pragma options ("vo13" , on)
            [Fact, Trait("Category", "Str")];
		    METHOD StringComparison_WINDOWS_notEXACT() AS VOID
				LOCAL uAB,uA AS USUAL
				LOCAL sAB,sA AS USUAL
				LOCAL c,e,vo13 AS USUAL
				vo13 := XSharp.RuntimeState.CompilerOptionVO13
				XSharp.RuntimeState.CompilerOptionVO13 := TRUE
				c := SetCollation(#WINDOWS)
				e := SetExact(FALSE)

				uAB := "AB"
				uA := "A"
				sAB := uAB
				sA := uA

				Assert.True ( "AB" = "A"  )
				Assert.False( "A" = "AB"  )
				Assert.True ( uAB = uA    )
				Assert.False( uA = uAB    )
				Assert.True ( sAB = sA    )
				Assert.False( sA = sAB    )

				Assert.True ( "AB" != "A" ) // Moronic VO behavior, different behavior with literals than with USUALs/STRINGs
				Assert.True ( "A" != "AB" )
				Assert.False( uAB != uA   )
				Assert.True ( uA != uAB   )
				Assert.False( sAB != sA   )
				Assert.True ( sA != sAB   )

				Assert.True ( "AB" >= "A" )
				Assert.True ( "AB" <= "A" )
				Assert.True ( uAB >= uA   )
				Assert.True ( uAB <= uA   )
				Assert.True ( sAB >= sA   )
				Assert.True ( sAB <= sA   )

				Assert.False( "AB" > "A"  )
				Assert.False( "AB" < "A"  )
				Assert.False( uAB > uA    )
				Assert.False( uAB < uA    )
				Assert.False( sAB > sA    )
				Assert.False( sAB < sA    )

				SetCollation(c)
				SetExact(e)

				XSharp.RuntimeState.CompilerOptionVO13 := vo13

            [Fact, Trait("Category", "Str")];
		    METHOD StringComparison_CLIPPER_notEXACT() AS VOID
				LOCAL uAB,uA AS USUAL
				LOCAL sAB,sA AS USUAL
				LOCAL c,e,vo13 AS USUAL
				vo13 := XSharp.RuntimeState.CompilerOptionVO13
				XSharp.RuntimeState.CompilerOptionVO13 := TRUE
				c := SetCollation(#CLIPPER)
				e := SetExact(FALSE)

				uAB := "AB"
				uA := "A"
				sAB := uAB
				sA := uA

				Assert.True ( "AB" = "A"  )
				Assert.False( "A" = "AB"  )
				Assert.True ( uAB = uA    )
				Assert.False( uA = uAB    )
				Assert.True ( sAB = sA    )
				Assert.False( sA = sAB    )

				Assert.True ( "AB" != "A" )
				Assert.True ( "A" != "AB" )
				Assert.False( uAB != uA   )
				Assert.True ( uA != uAB   )
				Assert.False( sAB != sA   )
				Assert.True ( sA != sAB   )

				Assert.True ( "AB" >= "A" )
				Assert.True ( "AB" <= "A" )
				Assert.True ( uAB >= uA   )
				Assert.True ( uAB <= uA   )
				Assert.True ( sAB >= sA   )
				Assert.True ( sAB <= sA   )

				Assert.False( "AB" > "A"  )
				Assert.False( "AB" < "A"  )
				Assert.False( uAB > uA    )
				Assert.False( uAB < uA    )
				Assert.False( sAB > sA    )
				Assert.False( sAB < sA    )

				SetCollation(c)
				SetExact(e)

				XSharp.RuntimeState.CompilerOptionVO13 := vo13

            [Fact, Trait("Category", "Str")];
		    METHOD StringComparison_WINDOWS_EXACT() AS VOID
				LOCAL uAB,uA AS USUAL
				LOCAL sAB,sA AS USUAL
				LOCAL c,e,vo13 AS USUAL
				vo13 := XSharp.RuntimeState.CompilerOptionVO13
				XSharp.RuntimeState.CompilerOptionVO13 := TRUE
				c := SetCollation(#WINDOWS)
				e := SetExact(TRUE)

				uAB := "AB"
				uA := "A"
				sAB := uAB
				sA := uA

				Assert.False( "AB" = "A"  )
				Assert.False( "A" = "AB"  )
				Assert.False( uAB = uA    )
				Assert.False( uA = uAB    )
				Assert.False( sAB = sA    )
				Assert.False( sA = sAB    )

				Assert.True ( "AB" != "A" )
				Assert.True ( "A" != "AB" )
				Assert.True ( uAB != uA   )
				Assert.True ( uA != uAB   )
				Assert.True ( sAB != sA   )
				Assert.True ( sA != sAB   )

				Assert.True ( "AB" >= "A" )
				Assert.False( "AB" <= "A" )
				Assert.True ( uAB >= uA   )
				Assert.False( uAB <= uA   )
				Assert.True ( sAB >= sA   )
				Assert.False( sAB <= sA   )

				Assert.True ( "AB" > "A"  )
				Assert.False( "AB" < "A"  )
				Assert.True ( uAB > uA    )
				Assert.False( uAB < uA    )
				Assert.True ( sAB > sA    )
				Assert.False( sAB < sA    )

				SetCollation(c)
				SetExact(e)

				XSharp.RuntimeState.CompilerOptionVO13 := vo13

            [Fact, Trait("Category", "Str")];
		    METHOD StringComparison_CLIPPER_EXACT() AS VOID
				LOCAL uAB,uA AS USUAL
				LOCAL sAB,sA AS USUAL
				LOCAL c,e,vo13 AS USUAL
				vo13 := XSharp.RuntimeState.CompilerOptionVO13
				XSharp.RuntimeState.CompilerOptionVO13 := TRUE
				c := SetCollation(#CLIPPER)
				e := SetExact(TRUE)

				uAB := "AB"
				uA := "A"
				sAB := uAB
				sA := uA

				Assert.False( "AB" = "A"  )
				Assert.False( "A" = "AB"  )
				Assert.False( uAB = uA    )
				Assert.False( uA = uAB    )
				Assert.False( sAB = sA    )
				Assert.False( sA = sAB    )

				Assert.True ( "AB" != "A" )
				Assert.True ( "A" != "AB" )
				Assert.True ( uAB != uA   )
				Assert.True ( uA != uAB   )
				Assert.True ( sAB != sA   )
				Assert.True ( sA != sAB   )

				Assert.True ( "AB" >= "A" )
				Assert.False( "AB" <= "A" )
				Assert.True ( uAB >= uA   )
				Assert.False( uAB <= uA   )
				Assert.True ( sAB >= sA   )
				Assert.False( sAB <= sA   )

				Assert.True ( "AB" > "A"  )
				Assert.False( "AB" < "A"  )
				Assert.True ( uAB > uA    )
				Assert.False( uAB < uA    )
				Assert.True ( sAB > sA    )
				Assert.False( sAB < sA    )

				SetCollation(c)
				SetExact(e)

				XSharp.RuntimeState.CompilerOptionVO13 := vo13

#pragma options ("vo13" , default)

	END CLASS

END NAMESPACE

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//
USING System
USING System.Collections.Generic
USING System.Linq
USING System.Text
USING XUnit

#pragma warnings(165, off)  // unassigned variables
#pragma warnings(219, off)  // assigned but not used

// Array tests are not working correctly yet with the current build
BEGIN NAMESPACE XSharp.VO.Tests

	CLASS StringTests

		[Fact, Trait("Category", "String")];
		METHOD MoreStringTests() AS VOID
			Assert.Equal("          ", Transform("", "@R XXXXXXXXXX")        )
			Assert.Equal("Italia    ", Transform("Italia", "@R XXXXXXXXXX")  )
			Assert.Equal("ITALIA    ", Transform("Italia", "@! XXXXXXXXXX")  )
			Assert.Equal("Italia    ", Transform("Italia", "XXXXXXXXXX")     )
			Assert.Equal("1234512345", Transform("1234512345", "XXXXXXXXXX") )
			Assert.Equal("1234"      , Transform("1234", "XX99") )
			Assert.Equal("ITALIA"    , Transform("Italia", "@!") )

			LOCAL c AS STRING
			c := "Not nil!"
			Assert.False(c == NIL)
			Assert.True(c != NIL)
			LOCAL u AS STRING
			u := "Not nil!"
			Assert.False(c == NIL)
			Assert.True(c != NIL)
		RETURN

		[Fact, Trait("Category", "StringEq")];
		METHOD StringEquality() AS VOID
			LOCAL c1,c2 AS STRING
			LOCAL u1,u2 AS USUAL
			LOCAL exact AS LOGIC
			u1 := c1 := "TESTLONG"
			u2 := c2 := "TEST"
			exact := SetExact( FALSE )

			Assert.Equal(TRUE, c1 = c2)
			Assert.Equal(TRUE, c1 != c2)

			Assert.Equal(TRUE, u1 = u2)
			Assert.Equal(FALSE, u1 != u2)

			SetExact( exact )
		RETURN

		[Fact, Trait("Category", "Str")];
		METHOD StrTests() AS VOID
			LOCAL deci,thou,digit,decimal,fixed_,digitfixed AS USUAL
			deci := SetDecimalSep(Asc("."))
			thou := SetThousandSep(Asc(","))
			digit := SetDigit(6)
			decimal := SetDecimal(3)
			fixed_ := SetFixed(FALSE)
			digitfixed := SetDigitFixed(FALSE)

			Assert.Equal( "     1.2"			, Str(1.2) )
			Assert.Equal( "    12.3"			, Str(12.3) )
			Assert.Equal( "    12.34"			, Str(12.34) )
			Assert.Equal( "   123.456"			, Str(123.456) )
			Assert.Equal( "  1234.567"			, Str(1234.567) )
			Assert.Equal( "  1234.5678"			, Str(1234.5678) )
			Assert.Equal( "  1234.5679012345"	, Str(1234.5679012345) )
			Assert.Equal( "123456.78901234568"	, Str(123456.78901234567) )
			Assert.Equal( "999999" , Str(999999) )
			Assert.Equal( "******" , Str(1000000) )

			Assert.Equal( "0.0" , Transform(0 , "9.9") )
			Assert.Equal( "1.0" , Transform(1 , "9.9") )
			Assert.Equal( "*.*" , Transform(-1 , "9.9") )
			SetDecimalSep(Asc(","))
			SetThousandSep(Asc("."))
			Assert.Equal( " 0,00" , Transform(0 , "99.99") )
			Assert.Equal( " 1,00" , Transform(1 , "99.99") )
			Assert.Equal( "-1,00" , Transform(-1 , "99.99") )

			Assert.Equal( "  0,00" , Transform(0 , "999.99") )
			Assert.Equal( "  0,0" , Transform(0 , "999.9") )
			Assert.Equal( " 0,0" , Transform(0 , "99.9") )

			SetFixed(TRUE)
			SetDigit(5)
			Assert.Equal("  123" , Str(123))
			Assert.Equal("123" , Str(123 , -1))
			Assert.Equal("123" , Str(123 , 3))
			Assert.Equal("-123" , Str(-123 , 4))
			Assert.Equal("-123" , Str(-123 , -1))
			Assert.Equal(" -123" , Str(-123))
			Assert.Equal(" 123" , Str(123 , 4))
			Assert.Equal("**" , Str(123 , 2))
			SetDigit(10)
			Assert.Equal(" 123456789" , Str(123456789))
			Assert.Equal("**********" , Str(12345678901))

			SetFixed(FALSE)
			SetDigit(5)
			Assert.Equal("  123" , Str(123))
			Assert.Equal("123" , Str(123 , -1))
			Assert.Equal("123" , Str(123 , 3))
			Assert.Equal("-123" , Str(-123 , 4))
			Assert.Equal("-123" , Str(-123 , -1))
			Assert.Equal(" -123" , Str(-123))
			Assert.Equal(" 123" , Str(123 , 4))
			Assert.Equal("**" , Str(123 , 2))
			SetDigit(10)
			Assert.Equal(" 123456789" , Str(123456789))
			Assert.Equal("**********" , Str(12345678901))

			SetDecimal(2)
			SetDecimalSep(Asc(","))
			SetThousandSep(Asc("."))
			Assert.Equal( "**",    Str(1.23 , 2 , 1) )
			Assert.Equal( "1,2",   Str(1.2 , 3) )
			Assert.Equal( "123",   Str(123.456 , 3) )

			Assert.Equal( "123",   Str(123.4567 , 3 , 1) )
			Assert.Equal( "123,",  Str(123.4567 , 4 , 2) )
			Assert.Equal( "123,4", Str(123.4567 , 5 , 3) )
			Assert.Equal( "****" , Str(123.4567 , 4 , 3) )
			Assert.Equal( "*****", Str(123.4567 , 5 , 4) )

			Assert.Equal( "***",   Str(-123.4567 , 3 , 1) )
			Assert.Equal( "-123",  Str(-123.4567 , 4 , 2) )
			Assert.Equal( "-123,", Str(-123.4567 , 5 , 3) )
			Assert.Equal( "****" , Str(-123.4567 , 4 , 3) )
			Assert.Equal( "*****", Str(-123.4567 , 5 , 4) )

			Assert.Equal( "0,0",   Str(0.0 , -1) )
			Assert.Equal( "0,1",   Str(0.1 , -1) )
			Assert.Equal( "-0,1",  Str(-0.1 , -1) )
			Assert.Equal( "0,000",   Str(0.0 , -1 , 3) )
			Assert.Equal( "0,100",   Str(0.1 , -1 , 3) )
			Assert.Equal( "-0,100",  Str(-0.1 , -1 , 3) )

			Assert.Equal( "  123"	, Str(FloatFormat(123 , 5, 0)) )
			Assert.Equal( "   123"	, Str(FloatFormat(123 , 6, 0)) )
			Assert.Equal( " 123,5"	, Str(FloatFormat(123.456 , 6, 1) ) )
			Assert.Equal( "123,46"	, Str(FloatFormat(123.456 , 6, 2) ) )
			Assert.Equal( " 123,46"	, Str(FloatFormat(123.456 , 7, 2) ) )

			SetDecimalSep(deci)
			SetThousandSep(thou)
			SetDigit(digit)
			SetDecimal(decimal)
			SetFixed(fixed_)
			SetDigitFixed(digitfixed)
		RETURN

		[Fact, Trait("Category", "Str")];
		METHOD Str_With_SetFixed_TRUE() AS VOID

		   SetDecimalSep(Asc("."))
		   SetThousandSep(Asc(","))
		   SetDecimal(3)
		   SetDigit(12)

		   SetFixed(TRUE)
		   SetDigitFixed(TRUE)

		   Assert.Equal( Str(12.34)            		, "          12.340")
		   Assert.Equal( Str1(12.34)          		, "          12.340")
		   Assert.Equal( Str(123.456)         		, "         123.456")
		   Assert.Equal( Str1(123.456)       		, "         123.456")
		   Assert.Equal( Str(1230.4567)         	, "        1230.457")
		   Assert.Equal( Str1(1230.4567)        	, "        1230.457")
		   Assert.Equal( Str(100000001234.4567)		, "100000001234.457")
		   Assert.Equal( Str1(100000001234.4567)	, "100000001234.457")
		   Assert.Equal( Str(1000000001234.4567)	, "****************")
		   Assert.True ( Str1(1000000001234.4567):StartsWith("********"))
		   Assert.Equal( Str(12.3)              	, "          12.300")
		   Assert.Equal( Str1(12.3)            		, "          12.300")
		   Assert.Equal( Str(12.34567)        	 	, "          12.346")
		   Assert.Equal( Str1(12.34567)        		, "          12.346")
		   Assert.Equal( Str(12.34 , 10, 2)    		, "     12.34")
		   Assert.Equal( Str(12.34 , 5, 2)     		, "12.34")
		   Assert.Equal( Str(12.34 , 4, 2)     		, "12.3")
		   Assert.Equal( Str(12.34 , 4, 1)     		, "12.3")
		   Assert.Equal( Str(12.34 , 2, 1)     		, "**")
		   Assert.Equal( Str3(12.34 , 10, 2)   		, "     12.34")
		   Assert.Equal( Str3(12.34 , 5, 2)    		, "12.34")
		   Assert.Equal( Str3(12.34 , 4, 2)     	, "12.3")
		   Assert.Equal( Str3(12.34 , 4, 1)     	, "12.3")
		   Assert.Equal( Str3(12.34 , 2, 1)    		, "**")
		   Assert.Equal( Str(-12.34)            	, "         -12.340")
		   Assert.Equal( Str1(-12.34)           	, "         -12.340")
		   Assert.Equal( Str(-12.3456)         		, "         -12.346")
		   Assert.Equal( Str1(-12.3456)         	, "         -12.346")
		   Assert.Equal( Str(-12.34 , 10, 2)    	, "    -12.34")
		   Assert.Equal( Str(-12.34 , 5, 2)     	, "-12.3")	 //VO wrong: -2.34
		   Assert.Equal( Str(-12.34 , 4, 2)     	, "-12.")    // VO wrong: -12.
		   Assert.Equal( Str(-12.34 , 4, 1)     	, "-12.")    //VO wrong: -2.3
	       Assert.Equal( Str(-12.34 , 4, 0)     	, " -12")    //VO wrong: -2.3
		   Assert.Equal( Str(-12.34 , 2, 1)     	, "**")

		   SetDigit(8)
		   SetDecimal(2)
		   SetDecimalSep(Asc(","))
		   SetThousandSep(Asc("."))

		   Assert.Equal( Str(123456789.1)	, "***********")
		   Assert.True(Str1(123456789.1):StartsWith("*****"))
		   Assert.Equal( Str(12345678.1)	, "12345678,10")
		   Assert.Equal(Str1(12345678.1)	, "12345678,10")
		   Assert.Equal( Str(1234567.1)		, " 1234567,10")
		   Assert.Equal(Str1(1234567.1)		, " 1234567,10")
		   Assert.Equal( Str(123456.1)		, "  123456,10")
		   Assert.Equal(Str1(123456.1)		, "  123456,10")

		RETURN

		[Fact, Trait("Category", "Str")];
		METHOD Str_With_SetFixed_FALSE() AS VOID

		   SetDecimalSep(Asc("."))
		   SetThousandSep(Asc(","))
		   SetDecimal(3)
		   SetDigit(12)

		   SetFixed(FALSE)
		   SetDigitFixed(FALSE)

		   Assert.Equal( Str(12.34)            		, "          12.34")
		   Assert.Equal( Str1(12.34)          		, "          12.34")
		   Assert.Equal( Str(123.456)         		, "         123.456")
		   Assert.Equal( Str1(123.456)				, "         123.456")
		   Assert.Equal( Str(1230.4567)         	, "        1230.4567")
		   Assert.Equal( Str1(1230.4567)        	, "        1230.4567")
		   Assert.Equal( Str(100000001234.4567)		, "100000001234.4567")
		   Assert.Equal( Str1(100000001234.4567)	, "100000001234.4567")
		   Assert.Equal( Str(1000000001234.4567)	, "*****************")
//		   Assert.Equal( Str1(1000000001234.4567)	, "*****************")
		   Assert.True(  Str1(1000000001234.4567):StartsWith("*")) // it's really impossible to replicate completely VO's insane behavior
		   Assert.Equal( Str(12.3)              	, "          12.3")
		   Assert.Equal( Str1(12.3)            		, "          12.3")
		   Assert.Equal( Str(12.34567)         		, "          12.34567")
		   Assert.Equal( Str1(12.34567)        		, "          12.34567")
		   Assert.Equal( Str(12.34 , 10, 2)    		, "     12.34")
		   Assert.Equal( Str(12.34 , 5, 2)     		, "12.34")
		   Assert.Equal( Str(12.34 , 4, 2)     		, "12.3") // VO returns 12.3
		   Assert.Equal( Str(12.34 , 4, 1)     		, "12.3")
		   Assert.Equal( Str(12.34 , 2, 1)     		, "**")
		   Assert.Equal( Str3(12.34 , 10, 2)   		, "     12.34")
		   Assert.Equal( Str3(12.34 , 5, 2)    		, "12.34")
		   Assert.Equal( Str3(12.34 , 4, 2)     	, "12.3")   // VO 12.3
		   Assert.Equal( Str3(12.34 , 4, 1)     	, "12.3")
		   Assert.Equal( Str3(12.34 , 2, 1)    		, "**")
		   Assert.Equal( Str(-12.34)            	, "         -12.34")
		   Assert.Equal( Str1(-12.34)           	, "         -12.34")
		   Assert.Equal( Str(-12.3456)         		, "         -12.3456")
		   Assert.Equal( Str1(-12.3456)         	, "         -12.3456")
		   Assert.Equal( Str(-12.34 , 10, 2)    	, "    -12.34")
		   Assert.Equal( Str(-12.34 , 5, 2)     	, "-12.3")	 //VO: -2.34
		   Assert.Equal( Str(-12.34 , 4, 2)     	, "-12.")    // VO
		   Assert.Equal( Str(-12.34 , 4, 1)     	, "-12.")    //VO: -2.3
		   Assert.Equal( Str(-12.34 , 2, 1)     	, "**")

		   SetDigit(8)
		   SetDecimal(2)

		   Assert.True( Str(123456789.1):StartsWith("*"))
		   Assert.True(Str1(123456789.1):StartsWith("*"))

		   Assert.Equal( "12.34" , Str(12.34 , -1))
		   Assert.Equal( "12.3400" , Str(12.34 , -1 , 4))
		   Assert.Equal( "1.1" , Str(1.1 , -1 , 1))

            [Fact, Trait("Category", "Str")];
		    METHOD Pad_Test() AS VOID
                LOCAL u AS USUAL
                Assert.Equal(Space(10), PadR(u,10))
                Assert.Equal(Space(10), Pad(u,10))
                Assert.Equal(Space(10), PadC(u,10))
                Assert.Equal(Space(10), PadL(u,10))
                u := "a"
                Assert.Equal("a         ", PadR(u,10))
                Assert.Equal("a         ", Pad(u,10))
                Assert.Equal("    a     ", PadC(u,10))
                Assert.Equal("----a-----", PadC(u,10,"-"))
                Assert.Equal("         a", PadL(u,10))
                u := 1
                Assert.Equal("1         ", PadR(u,10))
                Assert.Equal("1         ", Pad(u,10))
                Assert.Equal("    1     ", PadC(u,10))
                Assert.Equal("====1=====", PadC(u,10,"="))
                Assert.Equal("         1", PadL(u,10))
                u := 1.23
                SetDecimalSep(Asc("."))
                Assert.Equal("1.23      ", PadR(u,10))
                Assert.Equal("1.23      ", Pad(u,10))
                Assert.Equal("   1.23   ", PadC(u,10))
                Assert.Equal("...1.23...", PadC(u,10,"."))
                Assert.Equal("      1.23", PadL(u,10))

#pragma options ("vo13" , on)
            [Fact, Trait("Category", "Str")];
		    METHOD StringComparison_WINDOWS_notEXACT() AS VOID
				LOCAL u1,u2 AS USUAL
				LOCAL s1,s2 AS USUAL
				LOCAL c,e,vo13 AS USUAL
				vo13 := XSharp.RuntimeState.CompilerOptionVO13
				XSharp.RuntimeState.CompilerOptionVO13 := TRUE
				c := SetCollation(#WINDOWS)
				e := SetExact(FALSE)

				u1 := "AB"
				u2 := "A"
				s1 := u1
				s2 := u2

				Assert.True ( "AB" = "A"  )
				Assert.False( "A" = "AB"  )
				Assert.True ( u1 = u2     )
				Assert.False( u2 = u1     )
				Assert.True ( s1 = s2     )
				Assert.False( s2 = s1     )

				Assert.True ( "AB" >= "A" )
				Assert.True ( "AB" <= "A" )
				Assert.True ( u1 >= u2    )
				Assert.True ( u1 <= u2    )
				Assert.True ( s1 >= s2    )
				Assert.True ( s1 <= s2    )

				Assert.False( "AB" > "A"  )
				Assert.False( "AB" < "A"  )
				Assert.False( u1 > u2     )
				Assert.False( u1 < u2     )
				Assert.False( s1 > s2     )
				Assert.False( s1 < s2     )

				SetCollation(c)
				SetExact(e)

				XSharp.RuntimeState.CompilerOptionVO13 := vo13

            [Fact, Trait("Category", "Str")];
		    METHOD StringComparison_CLIPPER_notEXACT() AS VOID
				LOCAL u1,u2 AS USUAL
				LOCAL s1,s2 AS USUAL
				LOCAL c,e,vo13 AS USUAL
				vo13 := XSharp.RuntimeState.CompilerOptionVO13
				XSharp.RuntimeState.CompilerOptionVO13 := TRUE
				c := SetCollation(#CLIPPER)
				e := SetExact(FALSE)

				u1 := "AB"
				u2 := "A"
				s1 := u1
				s2 := u2

				Assert.True ( "AB" = "A"  )
				Assert.False( "A" = "AB"  )
				Assert.True ( u1 = u2     )
				Assert.False( u2 = u1     )
				Assert.True ( s1 = s2     )
				Assert.False( s2 = s1     )

				Assert.True ( "AB" >= "A" )
				Assert.True ( "AB" <= "A" )
				Assert.True ( u1 >= u2    )
				Assert.True ( u1 <= u2    )
				Assert.True ( s1 >= s2    )
				Assert.True ( s1 <= s2    )

				Assert.False( "AB" > "A"  )
				Assert.False( "AB" < "A"  )
				Assert.False( u1 > u2     )
				Assert.False( u1 < u2     )
				Assert.False( s1 > s2     )
				Assert.False( s1 < s2     )

				SetCollation(c)
				SetExact(e)

				XSharp.RuntimeState.CompilerOptionVO13 := vo13

            [Fact, Trait("Category", "Str")];
		    METHOD StringComparison_WINDOWS_EXACT() AS VOID
				LOCAL u1,u2 AS USUAL
				LOCAL s1,s2 AS USUAL
				LOCAL c,e,vo13 AS USUAL
				vo13 := XSharp.RuntimeState.CompilerOptionVO13
				XSharp.RuntimeState.CompilerOptionVO13 := TRUE
				c := SetCollation(#WINDOWS)
				e := SetExact(TRUE)

				u1 := "AB"
				u2 := "A"
				s1 := u1
				s2 := u2

				Assert.False( "AB" = "A"  )
				Assert.False( "A" = "AB"  )
				Assert.False( u1 = u2     )
				Assert.False( u2 = u1     )
				Assert.False( s1 = s2     )
				Assert.False( s2 = s1     )

				Assert.True ( "AB" >= "A" )
				Assert.False( "AB" <= "A" )
				Assert.True ( u1 >= u2    )
				Assert.False( u1 <= u2    )
				Assert.True ( s1 >= s2    )
				Assert.False( s1 <= s2    )

				Assert.True ( "AB" > "A"  )
				Assert.False( "AB" < "A"  )
				Assert.True ( u1 > u2     )
				Assert.False( u1 < u2     )
				Assert.True ( s1 > s2     )
				Assert.False( s1 < s2     )

				SetCollation(c)
				SetExact(e)

				XSharp.RuntimeState.CompilerOptionVO13 := vo13

            [Fact, Trait("Category", "Str")];
		    METHOD StringComparison_CLIPPER_EXACT() AS VOID
				LOCAL u1,u2 AS USUAL
				LOCAL s1,s2 AS USUAL
				LOCAL c,e,vo13 AS USUAL
				vo13 := XSharp.RuntimeState.CompilerOptionVO13
				XSharp.RuntimeState.CompilerOptionVO13 := TRUE
				c := SetCollation(#CLIPPER)
				e := SetExact(TRUE)

				u1 := "AB"
				u2 := "A"
				s1 := u1
				s2 := u2

				Assert.False( "AB" = "A"  )
				Assert.False( "A" = "AB"  )
				Assert.False( u1 = u2     )
				Assert.False( u2 = u1     )
				Assert.False( s1 = s2     )
				Assert.False( s2 = s1     )

				Assert.True ( "AB" >= "A" )
				Assert.False( "AB" <= "A" )
				Assert.True ( u1 >= u2    )
				Assert.False( u1 <= u2    )
				Assert.True ( s1 >= s2    )
				Assert.False( s1 <= s2    )

				Assert.True ( "AB" > "A"  )
				Assert.False( "AB" < "A"  )
				Assert.True ( u1 > u2     )
				Assert.False( u1 < u2     )
				Assert.True ( s1 > s2     )
				Assert.False( s1 < s2     )

				SetCollation(c)
				SetExact(e)

				XSharp.RuntimeState.CompilerOptionVO13 := vo13

#pragma options ("vo13" , default)

	END CLASS

END NAMESPACE


we can walk the polys too

we can walk the polys too

-- implement the idea described in
-- https://code.google.com/p/omega/wiki/IcebergTypes
--

import "../src/LangPrelude.prg" (maybeM)

data Thrist :: (l ~> l ~> *) ~> l ~> l ~> * where
  Nil :: Thrist k a a
  Cons :: k a b -> Thrist k b c -> Thrist k a c
 deriving List(t)

data Multiplicity :: *2 where
  Mono :: Multiplicity
  Poly :: Multiplicity

data Lev :: Multiplicity ~> *1 where
  ValueLevel :: Lev Mono
  LevelUp :: Lev m ~> Lev m
  PolyLevel :: Lev Poly -- level n .
 deriving syntax (lev) Nat(ValueLevel, LevelUp)

data Level :: Lev n ~> * where
  ValueLevel :: Level ValueLevel
  LevelUp :: Level l -> Level (LevelUp l)
  PolyLevel :: Level PolyLevel
 deriving syntax (l) Nat(ValueLevel, LevelUp)

data Signature = Sig -- for now

data Iceberg :: * ~> * ~> * where
  Constructor :: Label t -> Level l -> Signature -> Iceberg () ()

data Icename :: Tag ~> Tag ~> * where -- entities with certain name
  NamedConstructor :: Label t -> Level l -> Signature -> Icename t t

data Icelevel :: Lev n ~> Lev n ~> * where -- entities with certain level
  LevelConstructor :: LevelFits l' l => Label t -> Level l -> Signature -> Icelevel l' l'

data TagLev :: Multiplicity ~> *1 where
  TL :: Tag ~> Lev m ~> TagLev m

data Icenamelevel :: TagLev n ~> TagLev n ~> * where -- entities with certain level and name
  NamedLevelConstructor :: LevelFits l' l => Label t -> Level l -> Signature -> Icenamelevel (TL t l') (TL t l')

builtIns :: Thrist Iceberg () ()
builtIns = [ Constructor `Z 0l Sig, Constructor `S 0l Sig, Constructor natPrime 0l Sig
           , Constructor `Z 1l Sig, Constructor `S 1l Sig, Constructor `Nat 2l Sig
           , Constructor starN (LevelUp (LevelUp PolyLevel)) Sig
           , Constructor constraintN (LevelUp (LevelUp PolyLevel)) Sig
           , Constructor `MultValueAndUp PolyLevel Sig]t
  where HideLabel natPrime = newLabel "Nat'"
        HideLabel starN = newLabel "*n"
        HideLabel constraintN = newLabel "#n"

projectName :: Label l -> Thrist Iceberg () () -> Thrist Icename l l
projectName _ []t = []t
projectName l [Constructor l' lev sig; rest]t = case l `sameLabel` l' of
                                                L Eq -> [NamedConstructor l' lev sig; projectName l rest]t
                                                _ -> projectName l rest

projectName' :: Label t -> Thrist Icelevel l l -> Thrist Icenamelevel (TL t l) (TL t l)
projectName' _ []t = []t
projectName' t [LevelConstructor t' lev sig; rest]t = case t `sameLabel` t' of
                                                      L Eq -> [NamedLevelConstructor t' lev sig; projectName' t rest]t
                                                      _ -> projectName' t rest

-- inclusion relation on levels
--
prop LevelFits :: Lev n ~> Lev n' ~> * where
  BothValue :: LevelFits ValueLevel ValueLevel
  BothPoly :: LevelFits PolyLevel PolyLevel
  BothUp :: LevelFits k k' -> LevelFits (LevelUp k) (LevelUp k')
  ValuePoly :: LevelFits ValueLevel PolyLevel
  AbovePoly :: LevelFits (LevelUp k) PolyLevel

-- runtime compute level inclusion
--
fits :: Level l -> Level l' -> Maybe (LevelFits l l')
fits ValueLevel ValueLevel = Just BothValue
fits PolyLevel PolyLevel = Just BothPoly
fits (LevelUp l) (LevelUp l') = do ev <- fits l l'
                                   return $ BothUp ev
                                 where monad maybeM
fits ValueLevel PolyLevel = Just ValuePoly
fits (LevelUp l) PolyLevel = Just AbovePoly
fits _ _ = Nothing

projectLevel :: Level l -> Thrist Iceberg () () -> Thrist Icelevel l l
projectLevel _ []t = []t
projectLevel l [Constructor t l' sig; rest]t = case l `fits` l' of
                                               Just BothValue -> [LevelConstructor t l' sig; projectLevel l rest]t
                                               Just BothPoly -> [LevelConstructor t l' sig; projectLevel l rest]t
                                               Just (BothUp below) -> [LevelConstructor t l' sig; projectLevel l rest]t
                                               Just ValuePoly -> [LevelConstructor t l' sig; projectLevel l rest]t
                                               Just AbovePoly -> [LevelConstructor t l' sig; projectLevel l rest]t
                                               _ -> projectLevel l rest

projectLevel' :: Level l -> Thrist Icename t t -> Thrist Icenamelevel (TL t l) (TL t l)
projectLevel' _ []t = []t
projectLevel' l [NamedConstructor t l' sig; rest]t = case l `fits` l' of
                                                     Just BothValue -> [NamedLevelConstructor t l' sig; projectLevel' l rest]t
                                                     Just BothPoly -> [NamedLevelConstructor t l' sig; projectLevel' l rest]t
                                                     Just (BothUp below) -> [NamedLevelConstructor t l' sig; projectLevel' l rest]t
                                                     Just ValuePoly -> [NamedLevelConstructor t l' sig; projectLevel' l rest]t
                                                     Just AbovePoly -> [NamedLevelConstructor t l' sig; projectLevel' l rest]t
                                                     _ -> projectLevel' l rest

data Levels :: Lev m ~> Lev m ~> * where
  InLevel :: Thrist Icelevel l l -> Levels l (1+l)l

t3 :: Thrist Levels 0l 2l
t3 = [InLevel $ projectLevel 0l builtIns, InLevel $ projectLevel 1l builtIns]t

fibrateLevels :: Level l -> Thrist Iceberg () () -> Thrist Levels l a
fibrateLevels l berg = [InLevel $ projectLevel l berg; lazy (fibrateLevels (1+l)l berg)]t

[t30, t31, t32, t33; t34]t = fibrateLevels 0l builtIns
[t40, t41, t42, t43; t44]t = fibrateLevels PolyLevel builtIns