Added more test code.

Added more test code.

   *comment with spaces
#DEFINE cantbewrong
#DEFINE SPACE CHR
#IFDEF cantbewrong
#IF FILE ( 'test.h' )
   ***comment***
   # include  test.h
   # include  'test.h'
   # include  'test' + '.h'
   STORE 5 to  x && set x to 5
#ELSE
#ENDIF
   x = 'test' + CHR(13) + CHR(10)
   x = space(5)
   x = '' + CHR(13) + CHR(10)
#ELSE
_SCREEN.LOGO.TOP = (_SCREEN.HEIGHT-_SCREEN.LOGO.HEIGHT)/2-3

WAIT WINDOW space(3) + 'please wait' + CHR(32) NOWAIT TIMEOUT 1.3
#ENDIF

?LEFT('Hello, World', 5)
WAIT WINDOW space(3) + 'please wait' + CHR(32) NOWAIT TIMEOUT 1.3
md test - test
MD test+test
md (test+test)
*com;
ment
NOTE note;
comment
x = 5*2**3**4
x = (1+2)*3
None = .nUlL.
Bool = .Y.
somedate = { / / }

if x > 5
else
   ?'hello'
   ?'goodbye'
ENDif

if x > 5
**do nothing
else
endif

delete file test . h
delete file test.h
delete file x
delete file (x)
delete file '' + x

_screen.refresh
test.prg()
test.prg(1)

if .f.
else
DO CASE
   CASE X == 1 && case 1
      do case
         case x == 1

      endcase
      X = 2
   CASE X == 2 && case 2
      X = 3
   CASE X == 2 && case 2 again
      X = 3
   CASE X == 2
      X = 3
   CASE X == 2
      X = 3
   CASE X == 2
      X = 3
ENDCASE
endif

do case
endcase

do case
endcase &&empty case end with comment

t=u(v(w(x(y(z)))))

*** CREATE REPORT TABLE
CREATE TABLE REPORT FREE (NAME C(50), ST C(2), QUANTITY N(5, 0), RECEIVED L(1))
USE REPORT IN 0 SHARED
SELECT REPORT
APPEND BLANK

REPLACE REPORT.NAME WITH 'Michael'
REPLACE REPORT.ST WITH 'IA'
REPLACE REPORT.QUANTITY WITH 4
REPLACE REPORT.RECEIVED WITH .F.

GO TOP

FOR X = 1 TO REPORT.QUANITY
    SET PRINTER TO ALLTRIM('printer')
    REPORT FORM TEST.FRX TO PRINTER NOCONSOLE
    SET PRINTER TO
ENDFOR

FOR X = 1 TO REPORT.QUANITY
ENDFOR

tablename = 'REPORT'

USE (tablename) IN 0 SHARED

IF USED('REPORT')
   SELECT REPORT
   USE IN REPORT
ENDIF

DO test in test

IF FILE('DBFTABLE.DBF')
   USE DBFTABLE IN 0 SHARED
   SELECT DBFTABLE
   COPY STRUCTURE TO 'DBFTEMP.DBF'
   IF USED('DBFTABLE')
      SELECT DBFTABLE
      USE IN DBFTABLE
   ENDIF
   IF USED('DBFTEMP')
      SELECT DBFTEMP
      USE IN DBFTEMP
   ENDIF
ENDIF

FUNCTION test
   parameters a, b
   ?a, b

FUNCTION REPLACE_TEST(TABLENAME, FIELD_VAL)
   IF FILE(TABLE_NAME + '.DBF')
      USE (TABLENAME) IN 0 SHARED
      SELECT (TABLENAME)
      SELECT('TABLENAME')
      REPLACE ALL TEST WITH .T. FOR FIELD1 = FIELDVAL
      GO TOP
      SKIP -3
      GO BOTTOM
      GO 15
      USE IN SELECT(TABLENAME)
      USE IN SELECT('tablename')
      USE IN TABLENAME
      USE IN (TABLENAME)
      USE IN 'TABLENAME'
   ENDIF
   RETURN

DEFINE CLASS test as custom
   x = 3 && x is a thing in this class
   procedure init
      parameters initx, inity
      x = initx

   function athing(test)
      return this.x
   endfunc
ENDDEFINE

DEFINE CLASS test2 as form
   add object test as t with prop = 'hello'
   add object cbox as combobox
   x = 3
ENDDEFINE

   *comment with spaces
#DEFINE cantbewrong
#DEFINE SPACE CHR
#IFDEF cantbewrong
#IF FILE ( 'test.h' )
   ***comment***
   # include  test.h
   # include  'test.h'
   # include  'test' + '.h'
   STORE 5 to  x && set x to 5
#ELSE
#ENDIF
   x = 'test' + CHR(13) + CHR(10)
   x = space(5)
   x = '' + CHR(13) + CHR(10)
#ELSE
_SCREEN.LOGO.TOP = (_SCREEN.HEIGHT-_SCREEN.LOGO.HEIGHT)/2-3

WAIT WINDOW space(3) + 'please wait' + CHR(32) NOWAIT TIMEOUT 1.3
#ENDIF

?LEFT('Hello, World', 5)
WAIT WINDOW space(3) + 'please wait' + CHR(32) NOWAIT TIMEOUT 1.3
md test - test
MD test+test
md (test+test)
*com;
ment
NOTE note;
comment
x = 5*2**3**4
x = (1+2)*3
None = .nUlL.
Bool = .Y.
somedate = { / / }

if x > 5
else
   ?'hello'
   ?'goodbye'
ENDif

if x > 5
**do nothing
else
endif

delete file test . h
delete file test.h
delete file x
delete file (x)
delete file '' + x

_screen.refresh
test.prg()
test.prg(1)

if .f.
else
DO CASE
   CASE X == 1 && case 1
      do case
         case x == 1

      endcase
      X = 2
   CASE X == 2 && case 2
      X = 3
   CASE X == 2 && case 2 again
      X = 3
   CASE X == 2
      X = 3
   CASE X == 2
      X = 3
   CASE X == 2
      X = 3
ENDCASE
endif

do case
endcase

do case
endcase &&empty case end with comment

t=u(v(w(x(y(z)))))

*** CREATE REPORT TABLE
CREATE TABLE REPORT FREE (NAME C(50), ST C(2), QUANTITY N(5), RECEIVED L(1))
USE REPORT IN 0 SHARED
SELECT REPORT
APPEND BLANK

REPLACE REPORT.NAME WITH 'Michael'
REPLACE REPORT.ST WITH 'IA'
REPLACE REPORT.QUANTITY WITH 4
REPLACE REPORT.RECEIVED WITH .F.

GO TOP

FOR X = 1 TO REPORT.QUANITY
    SET PRINTER TO ALLTRIM('printer')
    REPORT FORM TEST.FRX TO PRINTER NOCONSOLE
    SET PRINTER TO
ENDFOR

FOR X = 1 TO REPORT.QUANITY
ENDFOR

tablename = 'REPORT'

USE (tablename) IN 0 SHARED

IF USED('REPORT')
   SELECT REPORT
   USE IN REPORT
ENDIF

DO test in test

FUNCTION test
   parameters a, b
   ?a, b

FUNCTION REPLACE_TEST(TABLENAME, FIELD_VAL)
   IF FILE(TABLE_NAME + '.DBF')
      USE (TABLENAME) IN 0 SHARED
      SELECT (TABLENAME)
      SELECT('TABLENAME')
      REPLACE ALL TEST WITH .T. FOR FIELD1 = FIELDVAL
      GO TOP
      SKIP -3
      GO BOTTOM
      GO 15
      USE IN SELECT(TABLENAME)
      USE IN SELECT('tablename')
      USE IN TABLENAME
      USE IN (TABLENAME)
      USE IN 'TABLENAME'
   ENDIF
   RETURN

DEFINE CLASS test as custom
   x = 3 && x is a thing in this class
   procedure init
      parameters initx, inity
      x = initx

   function athing(test)
      return this.x
   endfunc
ENDDEFINE

DEFINE CLASS test2 as form
   add object test as t with prop = 'hello'
   x = 3
ENDDEFINE


fix the constraint order

fix the constraint order

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 HiddenLev :: *1 where
  HideLev :: Lev m ~> HiddenLev

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

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 :: HiddenLev ~> HiddenLev ~> * where -- entities with certain level
  LevelConstructor :: Label t -> Level l -> Signature -> Icelevel (HideLev l) (HideLev l)

builtIn :: Thrist Iceberg () ()
builtIn = [ Constructor `Z 0l Sig, Constructor `S 0l Sig, Constructor natPrime 0l Sig
          , Constructor `Z 1l Sig, Constructor `S 1l Sig, Constructor `Nat 2l Sig]t
  where HideLabel natPrime = newLabel "Nat'"

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

projectLevel :: Level l -> Thrist Iceberg () () -> Thrist Icelevel (HideLev l) (HideLev l)
projectLevel _ []t = []t
{-
projectLevel l [Constructor t l' sig; rest]t = case sameLevel l l' of
                                               Just (Eq, Eq) -> [LevelConstructor t l' sig; projectLevel l rest]t
                                               _ -> projectLevel l rest

sameLevel :: Level l -> Level l' -> Maybe (Equal l l', Equal (HideLev l) (HideLev l'))
sameLevel ValueLevel ValueLevel = Just (Eq, Eq)
sameLevel PolyLevel PolyLevel = Just (Eq, Eq)
sameLevel (LevelUp l) (LevelUp l') = do (Eq, Eq) <- sameLevel l l'
                                        return (Eq, Eq)
                                      where monad maybeM
-}

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

-- should be LevelFits
prop LevelSubsumes :: Lev n ~> Lev n' ~> * where
  BothValue :: LevelSubsumes ValueLevel ValueLevel
  BothPoly :: LevelSubsumes PolyLevel PolyLevel
  BothUp :: LevelSubsumes k k' -> LevelSubsumes (LevelUp k) (LevelUp k')
  UpValuePoly :: LevelSubsumes (LevelUp ValueLevel) PolyLevel
  --Commutes :: LevelSubsumes k k' => LevelSubsumes k' k -- NOT!

-- should be 'fits'
subsumes :: Level l -> Level l' -> Maybe (LevelSubsumes l l')
subsumes ValueLevel ValueLevel = Just BothValue
subsumes PolyLevel PolyLevel = Just BothPoly
subsumes (LevelUp l) (LevelUp l') = do ev <- subsumes l l'
                                       return $ BothUp ev
                                     where monad maybeM
subsumes (LevelUp ValueLevel) PolyLevel = Just UpValuePoly
subsumes _ _ = Nothing

projectLevel' :: Level l -> Thrist Iceberg () () -> Thrist Icelevel' l l
projectLevel' _ []t = []t
projectLevel' l [Constructor t l' sig; rest]t = case subsumes l 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 UpValuePoly -> [LevelConstructor' t l' sig; projectLevel' l rest]t
                                               _ -> projectLevel' l rest

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 HiddenLev :: *1 where
  HideLev :: Lev m ~> HiddenLev

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

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 :: HiddenLev ~> HiddenLev ~> * where -- entities with certain level
  LevelConstructor :: Label t -> Level l -> Signature -> Icelevel (HideLev l) (HideLev l)

builtIn :: Thrist Iceberg () ()
builtIn = [ Constructor `Z 0l Sig, Constructor `S 0l Sig, Constructor natPrime 0l Sig
          , Constructor `Z 1l Sig, Constructor `S 1l Sig, Constructor `Nat 2l Sig]t
  where HideLabel natPrime = newLabel "Nat'"

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

projectLevel :: Level l -> Thrist Iceberg () () -> Thrist Icelevel (HideLev l) (HideLev l)
projectLevel _ []t = []t
{-
projectLevel l [Constructor t l' sig; rest]t = case sameLevel l l' of
                                               Just (Eq, Eq) -> [LevelConstructor t l' sig; projectLevel l rest]t
                                               _ -> projectLevel l rest

sameLevel :: Level l -> Level l' -> Maybe (Equal l l', Equal (HideLev l) (HideLev l'))
sameLevel ValueLevel ValueLevel = Just (Eq, Eq)
sameLevel PolyLevel PolyLevel = Just (Eq, Eq)
sameLevel (LevelUp l) (LevelUp l') = do (Eq, Eq) <- sameLevel l l'
                                        return (Eq, Eq)
                                      where monad maybeM
-}

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

-- should be LevelFits
prop LevelSubsumes :: Lev n ~> Lev n' ~> * where
  BothValue :: LevelSubsumes ValueLevel ValueLevel
  BothPoly :: LevelSubsumes PolyLevel PolyLevel
  BothUp :: LevelSubsumes k k' -> LevelSubsumes (LevelUp k) (LevelUp k')
  UpValuePoly :: LevelSubsumes (LevelUp ValueLevel) PolyLevel
  --Commutes :: LevelSubsumes k k' => LevelSubsumes k' k -- NOT!

-- should be 'fits'
subsumes :: Level l -> Level l' -> Maybe (LevelSubsumes l l')
subsumes ValueLevel ValueLevel = Just BothValue
subsumes PolyLevel PolyLevel = Just BothPoly
subsumes (LevelUp l) (LevelUp l') = do ev <- subsumes l l'
                                       return $ BothUp ev
                                     where monad maybeM
subsumes (LevelUp ValueLevel) PolyLevel = Just UpValuePoly
subsumes _ _ = Nothing

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


ZoomComplex now shows all trees, ZoomCompley only the first and the last one

-- 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 'output cards', so
--          - (output) cards   <-->  lines
--          - space between stacked cards <--> output cards
--          - lines disappear
--          -                (regular) cards appear

import "../tests/Nat.prg"

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 :: Tree' 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

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

data Stack :: Tree d ~> Tree e ~> * where
  Empty :: Corolla tr => Tree' tr -> Stack tr ()tr
  SubDone :: Stack ()tr []tr
  SubCont :: Stack ()tr tr -> Stack ()tr [tr]tr
  --Subdivision :: Stack ()tr sub -> Stack tr rest -> Stack tr [sub; rest]tr
  Encompass :: Subtree consumed tr => Stack consumed prod -> Stack tr prod
  -- 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
  -- we need a way to sequence cards
  -- MultiCard :: ??? Disjoint a b 0 => Subtree a -> Subtree b -> Stack tr a [proda, prodb]tr

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

  -- WARNING: [out']tr ---> one sibling for now

-- it remains to define corollas

prop Corolla :: Tree d ~> * where
  None' :: Corolla []tr
  One' :: Corolla tail -> Corolla [()tr; tail]tr

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

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

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

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

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

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

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

dolliFrame :: Stack [()tr]tr [()tr]tr
dolliFrame = Encompass (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 = SubDone

-- 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 = SubCont SubDone
-- drossed = (SubDone `On` NodeDone) In
-- Note: can we find a way to graft here? Then On would be feasible

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

--cyclops :: Stack [()tr]tr [[]tr, ()tr]tr
--cyclops = Pick (Beside ()ar ()ar SubDone (Exclude NodeDone)) NodeDone

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

-- 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 :: Tree what ~> Tree wher ~> Tree tree ~> Tree tree'
{extgraft what ()tr ()tr} = what
{extgraft what []tr ()tr} = ()tr
{extgraft what [head; tail]tr ()tr} = [{extgraft what head ()tr}; {extgraft what tail ()tr}]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

{- TODO? multiGraft :: Treelist -> where -> in -}

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

-}

-- 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 'output cards', so
--          - (output) cards   <-->  lines
--          - space between stacked cards <--> output cards
--          - lines disappear
--          -                (regular) cards appear

import "../tests/Nat.prg"

data ZoomComplex :: Tree e ~> Tree f ~> * where
  Nil :: ZoomComplex a a
  Cons :: Stack a b -> ZoomComplex b c -> ZoomComplex a c
 deriving List(cplx)

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 :: Tree' 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

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

data Stack :: Tree d ~> Tree e ~> * where
  Empty :: Corolla tr => Tree' tr -> Stack tr ()tr
  SubDone :: Stack ()tr []tr
  SubCont :: Stack ()tr tr -> Stack ()tr [tr]tr
  --Subdivision :: Stack ()tr sub -> Stack tr rest -> Stack tr [sub; rest]tr
  Encompass :: Subtree consumed tr => Stack consumed prod -> Stack tr prod
  -- 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
  -- we need a way to sequence cards
  -- MultiCard :: ??? Disjoint a b 0 => Subtree a -> Subtree b -> Stack tr a [proda, prodb]tr

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

  -- WARNING: [out']tr ---> one sibling for now

-- it remains to define corollas

prop Corolla :: Tree d ~> * where
  None' :: Corolla []tr
  One' :: Corolla tail -> Corolla [()tr; tail]tr

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

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

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

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

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

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

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

dolliFrame :: Stack [()tr]tr [()tr]tr
dolliFrame = Encompass (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 = SubDone

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

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

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

drossed :: Stack ()tr [[]tr]tr
drossed = SubCont SubDone
-- drossed = (SubDone `On` NodeDone) In
-- Note: can we find a way to graft here? Then On would be feasible

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

--cyclops :: Stack [()tr]tr [[]tr, ()tr]tr
--cyclops = Pick (Beside ()ar ()ar SubDone (Exclude NodeDone)) NodeDone

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

-- 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 :: Tree what ~> Tree wher ~> Tree tree ~> Tree tree'
{extgraft what ()tr ()tr} = what
{extgraft what []tr ()tr} = ()tr
{extgraft what [head; tail]tr ()tr} = [{extgraft what head ()tr}; {extgraft what tail ()tr}]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

{- TODO? multiGraft :: Treelist -> where -> in -}

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

-}


this is completely WIP, actually borderline BS ;-)

-- 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.

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

-- 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 :: (k ~> *) ~> * where
  Var :: tf a -> LC tf
  App :: LC tf -> LC tf -> LC tf
  Lam :: tf a -> LC tf -> LC tf
  LetRec :: tf a -> LC tf -> LC tf -> LC 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)

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

data DeBrujnContext :: (value ~> *) ~> Dict Nat value ~> * where
  DeBrujnEmpty :: DeBrujnContext value {}dict
  DeBrujnExtend :: DeBrujnContext value dict -> value v -> DeBrujnContext 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 :: DeBrujnContext 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

toDeBruijn :: DeBrujnContext Label dict -> LC Label -> Maybe (LC 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'

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

-- 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 k -> LC 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 v) e -- Let n v e -- Omega pattern bug???

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

-- shapes

kind Shape = Lm Shape | Ap Shape Shape | Rf Nat

--- ####### LC should be (primarily) parametrized in shape

data Shape' :: Shape ~> * where
  Ref :: Nat' n -> Shape' (Rf n)
  Lm :: Shape' inner -> Shape' (Lm inner)
  --Lm :: Shape' inner -> Shape' (Lm inner)

shape :: LC Nat' -> LC Shape'
shape (Var n) = Var (Ref n)
--shape (Lam n e) = Lam (Lm $ shape' e) $ shape e
shape (Lam n e) = Lam (Lm $ undefined) $ shape e

--shape' :: LC Nat' -> Shape' sh
--shape (Var n) = Ref n
--shape' (Var n) = Ref n

{-
data Shape :: *1 where
  Lm :: Shape ~> Shape
  Ap :: Shape ~> Shape ~> Shape
  Rf ::
-}

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

context :: DeBrujnContext Nat' dict -> LC Nat' -> LC 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))


separate levels and expressions

separate levels and expressions

-- parametric HOAS (PHOAS) representation of terms
-- advocated by Chipala and B. Oliveira
--

data Ptm a l = Var a
           | Lam (a -> Ptm a l)
           | Lev (l -> Ptm  a l)
           | App (Ptm a l) (Ptm a l)

data Tm = Tm (forall a l . Ptm a l)

-- illegal
--
##test "not parametric"
 ill = Tm (Lam (\a -> a + 2))

##test "not parametric: expr var in level context"
 ill = Tm (Lev (\a -> App (Var a) (Var a)))

-- this is parametric
--
leg = Tm (Lam (\a -> App (Var a) (Var a)))

-- parametric HOAS (PHOAS) representation of terms
-- advocated by Chipala and B. Oliveira
--

data Ptm a = Var a
           | Lam (a -> Ptm a)
           | App (Ptm a) (Ptm a)

data Tm = Tm (forall a . Ptm a)

-- illegal
--
##test "not parametric"
 ill = Tm (Lam (\a -> a + 2))

-- this is parametric
--
leg = Tm (Lam (\a -> App (Var a) (Var a)))


fix syntax of Odd and Even data types also correctly increment the type parameter and I felt free to name types and constructors identically

import "../src/LangPrelude.prg" (id,Monad,maybeM)

monad maybeM

data Equal :: *0 ~> *0 ~> *0 where
   Eq :: (b -> b) -> (b -> b) -> Equal b b

self = Eq id id

data Rep :: *0 ~> *0 where
   Rint :: Rep Int
   Rchar :: Rep Char
   Runit :: Rep ()
   Rpair :: (Rep a) -> (Rep b) -> Rep ((a,b))
   Rsum :: (Rep a) -> (Rep b) -> Rep ((a+b))
   Rcon :: ([Char]) -> (Rep t) -> Rep t
   Rdata :: (Rep i) -> (t -> i) -> (i -> t) -> Rep t

test :: Rep a -> Rep b -> Maybe (Equal a b)
test Rint Rint = return self
test Rchar Rchar = return self
test Runit Runit = return self
test (Rpair x y) (Rpair a b) =
  do { Eq f g <- test x a; Eq h i <- test y b; return self }
test (Rsum x y) (Rsum a b) =
  do { Eq f g <- test x a; Eq h i <- test y b; return self }
test (Rcon s x) (Rcon c y) =
  if eqStr s c then test x y else Nothing
test _ _ = Nothing

list :: Rep a -> Rep [a]
list x = Rdata (Rsum (Rcon "[]" Runit) (Rcon ":" (Rpair x (lazy (list x))))) h g
  where h [] = L ()
        h (x:xs) = R (x,xs)
        g (L ()) = []
        g (R (x,xs)) = x:xs

sum :: Rep a -> a -> Int
sum Rint n = n
sum (Rpair r s) (x,y) = sum r x + sum s y
sum (Rsum r s) (L x) = sum r x
sum (Rsum r s) (R x) = sum s x
sum (Rdata i f g) x = sum i (f x)
sum (Rcon s r) x = sum r x
sum _ x = 0

fst(x,y) = x
snd (x,y) = y

sum2 :: Rep a -> Code a -> Code Int
sum2 Rint x = x
sum2 Runit x = [| 0 |]
sum2 (Rpair x y) z = [| $(sum2 x [| fst $z |]) + $(sum2 y [| snd $z |]) |]
sum2 (Rsum r s) x = [| case $x of
                         L m -> $(sum2 r [| m |])
                         R m -> $(sum2 s [| m |]) |]

sum3 x = [| \ w -> $(sum2 x [| w |]) |]

r1 = Rpair Rint (Rsum Rint Runit)

data Even :: Nat ~> *0 where
  Base :: Even 0t
  Even :: Odd n -> Even (S n)

data Odd :: Nat ~> *0 where
  Odd :: Even n -> Odd (S n)

import "../src/LangPrelude.prg" (id,Monad,maybeM)

monad maybeM

data Equal :: *0 ~> *0 ~> *0 where
   Eq :: (b -> b) -> (b -> b) -> Equal b b

self = Eq id id

data Rep :: *0 ~> *0 where
   Rint :: Rep Int
   Rchar :: Rep Char
   Runit :: Rep ()
   Rpair :: (Rep a) -> (Rep b) -> Rep ((a,b))
   Rsum :: (Rep a) -> (Rep b) -> Rep ((a+b))
   Rcon :: ([Char]) -> (Rep t) -> Rep t
   Rdata :: (Rep i) -> (t -> i) -> (i -> t) -> Rep t

test :: Rep a -> Rep b -> Maybe (Equal a b)
test Rint Rint = return self
test Rchar Rchar = return self
test Runit Runit = return self
test (Rpair x y) (Rpair a b) =
  do { Eq f g <- test x a; Eq h i <- test y b; return self }
test (Rsum x y) (Rsum a b) =
  do { Eq f g <- test x a; Eq h i <- test y b; return self }
test (Rcon s x) (Rcon c y) =
  if eqStr s c then test x y else Nothing
test _ _ = Nothing

list :: Rep a -> Rep [a]
list x = Rdata (Rsum (Rcon "[]" Runit) (Rcon ":" (Rpair x (lazy (list x))))) h g
  where h [] = L ()
        h (x:xs) = R (x,xs)
        g (L ()) = []
        g (R (x,xs)) = x:xs

sum :: Rep a -> a -> Int
sum Rint n = n
sum (Rpair r s) (x,y) = sum r x + sum s y
sum (Rsum r s) (L x) = sum r x
sum (Rsum r s) (R x) = sum s x
sum (Rdata i f g) x = sum i (f x)
sum (Rcon s r) x = sum r x
sum _ x = 0

fst(x,y) = x
snd (x,y) = y

sum2 :: Rep a -> Code a -> Code Int
sum2 Rint x = x
sum2 Runit x = [| 0 |]
sum2 (Rpair x y) z = [| $(sum2 x [| fst $z |]) + $(sum2 y [| snd $z |]) |]
sum2 (Rsum r s) x = [| case $x of
                         L m -> $(sum2 r [| m |])
                         R m -> $(sum2 s [| m |]) |]

sum3 x = [| \ w -> $(sum2 x [| w |]) |]

r1 = Rpair Rint (Rsum Rint Runit)

data Even:: Nat ~> *0
  Base :: Even 0t
  Ev :: Odd n -> Even (S n)
data Odd:: Nat ~> *0
  Od:: Even n -> Odd n


codegen/QtScriptTools: updated

codegen/QtScriptTools: updated

Modified:
codegen/QtScriptTools/QScriptEngineDebugger.prg

%%
%% Qt5xHb - Bindings libraries for Harbour/xHarbour and Qt Framework 5
%%
%% Copyright (C) 2018 Marcos Antonio Gambeta <marcosgambeta AT outlook DOT com>
%%

$header

#include "hbclass.ch"

$addRequests

$beginClassFrom=QObject

$addMethods

$addSignals

$endClass

$destructor

#pragma BEGINDUMP

$includes

#include <QAction>
#include <QMenu>
#include <QToolBar>
#include <QMainWindow>

$prototype=QScriptEngineDebugger(QObject * parent = 0)
$constructor=|new|QObject *=0

$deleteMethod

$prototype=QAction * action(DebuggerAction action) const
$method=|QAction *|action|QScriptEngineDebugger::DebuggerAction

$prototype=void attachTo(QScriptEngine * engine)
$method=|void|attachTo|QScriptEngine *

$prototype=bool autoShowStandardWindow() const
$method=|bool|autoShowStandardWindow|

$prototype=QMenu * createStandardMenu(QWidget * parent = 0)
$method=|QMenu *|createStandardMenu|QWidget *=0

$prototype=QToolBar * createStandardToolBar(QWidget * parent = 0)
$method=|QToolBar *|createStandardToolBar|QWidget *=0

$prototype=void detach()
$method=|void|detach|

$prototype=void setAutoShowStandardWindow(bool autoShow)
$method=|void|setAutoShowStandardWindow|bool

$prototype=QMainWindow * standardWindow() const
$method=|QMainWindow *|standardWindow|

$prototype=DebuggerState state() const
$method=|QScriptEngineDebugger::DebuggerState|state|

$prototype=QWidget * widget(DebuggerWidget widget) const
$method=|QWidget *|widget|QScriptEngineDebugger::DebuggerWidget

$beginSignals
$signal=|evaluationResumed()
$signal=|evaluationSuspended()
$endSignals

#pragma ENDDUMP

%%
%% Qt5xHb - Bindings libraries for Harbour/xHarbour and Qt Framework 5
%%
%% Copyright (C) 2018 Marcos Antonio Gambeta <marcosgambeta AT outlook DOT com>
%%

$header

#include "hbclass.ch"

$addRequests

$beginClassFrom=QObject

   METHOD new
   METHOD delete
   METHOD action
   METHOD attachTo
   METHOD autoShowStandardWindow
   METHOD createStandardMenu
   METHOD createStandardToolBar
   METHOD detach
   METHOD setAutoShowStandardWindow
   METHOD standardWindow
   METHOD state
   METHOD widget

$addSignals

$endClass

$destructor

#pragma BEGINDUMP

$includes

#include <QAction>
#include <QMenu>
#include <QToolBar>
#include <QMainWindow>

$prototype=QScriptEngineDebugger(QObject * parent = 0)
$constructor=|new|QObject *=0

$deleteMethod

$prototype=QAction * action(DebuggerAction action) const
$method=|QAction *|action|QScriptEngineDebugger::DebuggerAction

$prototype=void attachTo(QScriptEngine * engine)
$method=|void|attachTo|QScriptEngine *

$prototype=bool autoShowStandardWindow() const
$method=|bool|autoShowStandardWindow|

$prototype=QMenu * createStandardMenu(QWidget * parent = 0)
$method=|QMenu *|createStandardMenu|QWidget *=0

$prototype=QToolBar * createStandardToolBar(QWidget * parent = 0)
$method=|QToolBar *|createStandardToolBar|QWidget *=0

$prototype=void detach()
$method=|void|detach|

$prototype=void setAutoShowStandardWindow(bool autoShow)
$method=|void|setAutoShowStandardWindow|bool

$prototype=QMainWindow * standardWindow() const
$method=|QMainWindow *|standardWindow|

$prototype=DebuggerState state() const
$method=|QScriptEngineDebugger::DebuggerState|state|

$prototype=QWidget * widget(DebuggerWidget widget) const
$method=|QWidget *|widget|QScriptEngineDebugger::DebuggerWidget

$beginSignals
$signal=|evaluationResumed()
$signal=|evaluationSuspended()
$endSignals

#pragma ENDDUMP


source/QtWinExtras: updated

source/QtWinExtras: updated

Modified:
source/QtWinExtras/QtWin.prg

/*

  Qt5xHb - Bindings libraries for Harbour/xHarbour and Qt Framework 5

  Copyright (C) 2018 Marcos Antonio Gambeta <marcosgambeta AT outlook DOT com>

*/

/*
  DO NOT EDIT THIS FILE - the content was created using a source code generator
*/

#include "hbclass.ch"

#ifndef QT5XHB_NO_REQUESTS
REQUEST QCOLOR
REQUEST QIMAGE
REQUEST QPIXMAP
REQUEST QREGION
#endif

CLASS QtWin

   DATA pointer
   DATA self_destruction INIT .F.

   METHOD createMask
   METHOD toHBITMAP
   METHOD fromHBITMAP
   METHOD toHICON
   METHOD imageFromHBITMAP
   METHOD fromHICON
   METHOD toHRGN
   METHOD fromHRGN
   METHOD stringFromHresult
   METHOD errorStringFromHresult
   METHOD colorizationColor
   METHOD realColorizationColor
   METHOD setWindowExcludedFromPeek
   METHOD isWindowExcludedFromPeek
   METHOD setWindowDisallowPeek
   METHOD isWindowPeekDisallowed
   METHOD setWindowFlip3DPolicy
   METHOD windowFlip3DPolicy
   METHOD extendFrameIntoClientArea
   METHOD resetExtendedFrame
   METHOD enableBlurBehindWindow
   METHOD disableBlurBehindWindow
   METHOD isCompositionEnabled
   METHOD setCompositionEnabled
   METHOD isCompositionOpaque
   METHOD setCurrentProcessExplicitAppUserModelID
   METHOD markFullscreenWindow
   METHOD taskbarActivateTab
   METHOD taskbarActivateTabAlt
   METHOD taskbarAddTab
   METHOD taskbarDeleteTab

   METHOD newFrom
   METHOD newFromObject
   METHOD newFromPointer
   METHOD selfDestruction
   METHOD setSelfDestruction

   DESTRUCTOR destroyObject

END CLASS

PROCEDURE destroyObject () CLASS QtWin
   IF ::self_destruction
      ::delete()
   ENDIF
RETURN

#pragma BEGINDUMP

#include <Qt>

#ifndef __XHARBOUR__
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#include <QtWin>
#endif
#endif

#include "qt5xhb_common.h"
#include "qt5xhb_macros.h"
#include "qt5xhb_utils.h"

#ifdef __XHARBOUR__
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#include <QtWin>
#endif
#endif

/*
static HBITMAP createMask(const QBitmap &bitmap)
*/
HB_FUNC_STATIC( QTWIN_CREATEMASK )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISQBITMAP(1) )
  {
#endif
      hb_retptr( (HBITMAP) QtWin::createMask ( *PQBITMAP(1) ) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static HBITMAP toHBITMAP(const QPixmap &p, HBitmapFormat format = HBitmapNoAlpha)
*/
HB_FUNC_STATIC( QTWIN_TOHBITMAP )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISBETWEEN(1,2) && ISQPIXMAP(1) && ISOPTNUM(2) )
  {
#endif
      hb_retptr( (HBITMAP) QtWin::toHBITMAP ( *PQPIXMAP(1), ISNIL(2)? (QtWin::HBitmapFormat) QtWin::HBitmapNoAlpha : (QtWin::HBitmapFormat) hb_parni(2) ) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static QPixmap fromHBITMAP(HBITMAP bitmap, HBitmapFormat format = HBitmapNoAlpha)
*/
HB_FUNC_STATIC( QTWIN_FROMHBITMAP )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISBETWEEN(1,2) && ISPOINTER(1) && ISOPTNUM(2) )
  {
#endif
      QPixmap * ptr = new QPixmap( QtWin::fromHBITMAP ( (HBITMAP) hb_parptr(1), ISNIL(2)? (QtWin::HBitmapFormat) QtWin::HBitmapNoAlpha : (QtWin::HBitmapFormat) hb_parni(2) ) );
      _qt5xhb_createReturnClass ( ptr, "QPIXMAP", true );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static HICON toHICON(const QPixmap &p)
*/
HB_FUNC_STATIC( QTWIN_TOHICON )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISQPIXMAP(1) )
  {
#endif
      hb_retptr( (HICON) QtWin::toHICON ( *PQPIXMAP(1) ) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static QImage imageFromHBITMAP(HDC hdc, HBITMAP bitmap, int width, int height)
*/
HB_FUNC_STATIC( QTWIN_IMAGEFROMHBITMAP )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(4) && ISPOINTER(1) && ISPOINTER(2) && ISNUM(3) && ISNUM(4) )
  {
#endif
      QImage * ptr = new QImage( QtWin::imageFromHBITMAP ( (HDC) hb_parptr(1), (HBITMAP) hb_parptr(2), PINT(3), PINT(4) ) );
      _qt5xhb_createReturnClass ( ptr, "QIMAGE", true );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static QPixmap fromHICON(HICON icon)
*/
HB_FUNC_STATIC( QTWIN_FROMHICON )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISPOINTER(1) )
  {
#endif
      QPixmap * ptr = new QPixmap( QtWin::fromHICON ( (HICON) hb_parptr(1) ) );
      _qt5xhb_createReturnClass ( ptr, "QPIXMAP", true );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static HRGN toHRGN(const QRegion &region)
*/
HB_FUNC_STATIC( QTWIN_TOHRGN )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISQREGION(1) )
  {
#endif
      hb_retptr( (HRGN) QtWin::toHRGN ( *PQREGION(1) ) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static QRegion fromHRGN(HRGN hrgn)
*/
HB_FUNC_STATIC( QTWIN_FROMHRGN )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISPOINTER(1) )
  {
#endif
      QRegion * ptr = new QRegion( QtWin::fromHRGN ( (HRGN) hb_parptr(1) ) );
      _qt5xhb_createReturnClass ( ptr, "QREGION", true );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static QString stringFromHresult(HRESULT hresult)
*/
HB_FUNC_STATIC( QTWIN_STRINGFROMHRESULT )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef Q_OS_WIN64
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISPOINTER(1) )
  {
#endif
      RQSTRING( QtWin::stringFromHresult ( (HRESULT) hb_parptr(1) ) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
#endif
}

/*
static QString errorStringFromHresult(HRESULT hresult)
*/
HB_FUNC_STATIC( QTWIN_ERRORSTRINGFROMHRESULT )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef Q_OS_WIN64
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISPOINTER(1) )
  {
#endif
      RQSTRING( QtWin::errorStringFromHresult ( (HRESULT) hb_parptr(1) ) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
#endif
}

/*
static QColor colorizationColor(bool *opaqueBlend = 0)
*/
HB_FUNC_STATIC( QTWIN_COLORIZATIONCOLOR )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISBETWEEN(0,1) && ISOPTLOG(1) )
  {
#endif
     bool par1;
      QColor * ptr = new QColor( QtWin::colorizationColor ( &par1 ) );
      _qt5xhb_createReturnClass ( ptr, "QCOLOR", true );
     hb_storl( par1, 1 );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static QColor realColorizationColor()
*/
HB_FUNC_STATIC( QTWIN_REALCOLORIZATIONCOLOR )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(0) )
  {
#endif
      QColor * ptr = new QColor( QtWin::realColorizationColor () );
      _qt5xhb_createReturnClass ( ptr, "QCOLOR", true );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static void setWindowExcludedFromPeek(QWindow *window, bool exclude)
*/
HB_FUNC_STATIC( QTWIN_SETWINDOWEXCLUDEDFROMPEEK )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(2) && ISQWINDOW(1) && ISLOG(2) )
  {
#endif
      QtWin::setWindowExcludedFromPeek ( PQWINDOW(1), PBOOL(2) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static bool isWindowExcludedFromPeek(QWindow *window)
*/
HB_FUNC_STATIC( QTWIN_ISWINDOWEXCLUDEDFROMPEEK )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
#endif
      RBOOL( QtWin::isWindowExcludedFromPeek ( PQWINDOW(1) ) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static void setWindowDisallowPeek(QWindow *window, bool disallow)
*/
HB_FUNC_STATIC( QTWIN_SETWINDOWDISALLOWPEEK )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(2) && ISQWINDOW(1) && ISLOG(2) )
  {
#endif
      QtWin::setWindowDisallowPeek ( PQWINDOW(1), PBOOL(2) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static bool isWindowPeekDisallowed(QWindow *window)
*/
HB_FUNC_STATIC( QTWIN_ISWINDOWPEEKDISALLOWED )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
#endif
      RBOOL( QtWin::isWindowPeekDisallowed ( PQWINDOW(1) ) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static void setWindowFlip3DPolicy(QWindow *window, WindowFlip3DPolicy policy)
*/
HB_FUNC_STATIC( QTWIN_SETWINDOWFLIP3DPOLICY )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(2) && ISQWINDOW(1) && ISNUM(2) )
  {
#endif
      QtWin::setWindowFlip3DPolicy ( PQWINDOW(1), (QtWin::WindowFlip3DPolicy) hb_parni(2) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static WindowFlip3DPolicy windowFlip3DPolicy(QWindow *)
*/
HB_FUNC_STATIC( QTWIN_WINDOWFLIP3DPOLICY )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
#endif
      RENUM( QtWin::windowFlip3DPolicy ( PQWINDOW(1) ) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static void extendFrameIntoClientArea(QWindow *window, int left, int top, int right, int bottom)
*/
void QtWin_extendFrameIntoClientArea1 ()
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))

      QtWin::extendFrameIntoClientArea ( PQWINDOW(1), PINT(2), PINT(3), PINT(4), PINT(5) );

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void extendFrameIntoClientArea(QWindow *window, const QMargins &margins)
*/
void QtWin_extendFrameIntoClientArea2 ()
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))

      QtWin::extendFrameIntoClientArea ( PQWINDOW(1), *PQMARGINS(2) );

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

//[1]void extendFrameIntoClientArea(QWindow *window, int left, int top, int right, int bottom)
//[2]void extendFrameIntoClientArea(QWindow *window, const QMargins &margins)

HB_FUNC_STATIC( QTWIN_EXTENDFRAMEINTOCLIENTAREA )
{
  if( ISNUMPAR(5) && ISQWINDOW(1) && ISNUM(2) && ISNUM(3) && ISNUM(4) && ISNUM(5) )
  {
    QtWin_extendFrameIntoClientArea1();
  }
  else if( ISNUMPAR(2) && ISQWINDOW(1) && ISQMARGINS(2) )
  {
    QtWin_extendFrameIntoClientArea2();
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
}

/*
static void resetExtendedFrame(QWindow *window)
*/
HB_FUNC_STATIC( QTWIN_RESETEXTENDEDFRAME )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
#endif
      QtWin::resetExtendedFrame ( PQWINDOW(1) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void enableBlurBehindWindow(QWindow *window, const QRegion &region)
*/
void QtWin_enableBlurBehindWindow1 ()
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))

      QtWin::enableBlurBehindWindow ( PQWINDOW(1), *PQREGION(2) );

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void enableBlurBehindWindow(QWindow *window)
*/
void QtWin_enableBlurBehindWindow2 ()
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))

      QtWin::enableBlurBehindWindow ( PQWINDOW(1) );

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

//[1]void enableBlurBehindWindow(QWindow *window, const QRegion &region)
//[2]void enableBlurBehindWindow(QWindow *window)

HB_FUNC_STATIC( QTWIN_ENABLEBLURBEHINDWINDOW )
{
  if( ISNUMPAR(1) && ISQWINDOW(1) && ISQREGION(2) )
  {
    QtWin_enableBlurBehindWindow1();
  }
  else if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
    QtWin_enableBlurBehindWindow2();
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
}

/*
static void disableBlurBehindWindow(QWindow *window)
*/
HB_FUNC_STATIC( QTWIN_DISABLEBLURBEHINDWINDOW )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
#endif
      QtWin::disableBlurBehindWindow ( PQWINDOW(1) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static bool isCompositionEnabled()
*/
HB_FUNC_STATIC( QTWIN_ISCOMPOSITIONENABLED )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(0) )
  {
#endif
      RBOOL( QtWin::isCompositionEnabled () );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static void setCompositionEnabled(bool enabled)
*/
HB_FUNC_STATIC( QTWIN_SETCOMPOSITIONENABLED )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISLOG(1) )
  {
#endif
      QtWin::setCompositionEnabled ( PBOOL(1) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static bool isCompositionOpaque()
*/
HB_FUNC_STATIC( QTWIN_ISCOMPOSITIONOPAQUE )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(0) )
  {
#endif
      RBOOL( QtWin::isCompositionOpaque () );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static void setCurrentProcessExplicitAppUserModelID(const QString &id)
*/
HB_FUNC_STATIC( QTWIN_SETCURRENTPROCESSEXPLICITAPPUSERMODELID )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISCHAR(1) )
  {
#endif
      QtWin::setCurrentProcessExplicitAppUserModelID ( PQSTRING(1) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void markFullscreenWindow(QWindow *, bool fullscreen = true)
*/
HB_FUNC_STATIC( QTWIN_MARKFULLSCREENWINDOW )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISBETWEEN(1,2) && ISQWINDOW(1) && ISOPTLOG(2) )
  {
#endif
      QtWin::markFullscreenWindow ( PQWINDOW(1), OPBOOL(2,true) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void taskbarActivateTab(QWindow *)
*/
HB_FUNC_STATIC( QTWIN_TASKBARACTIVATETAB )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
#endif
      QtWin::taskbarActivateTab ( PQWINDOW(1) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void taskbarActivateTabAlt(QWindow *)
*/
HB_FUNC_STATIC( QTWIN_TASKBARACTIVATETABALT )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
#endif
      QtWin::taskbarActivateTabAlt ( PQWINDOW(1) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void taskbarAddTab(QWindow *)
*/
HB_FUNC_STATIC( QTWIN_TASKBARADDTAB )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
#endif
      QtWin::taskbarAddTab ( PQWINDOW(1) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void taskbarDeleteTab(QWindow *)
*/
HB_FUNC_STATIC( QTWIN_TASKBARDELETETAB )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
#endif
      QtWin::taskbarDeleteTab ( PQWINDOW(1) );
#ifndef QT5XHB_DONT_CHECK_PARAMETERS
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

HB_FUNC_STATIC( QTWIN_NEWFROM )
{
  PHB_ITEM self = hb_stackSelfItem();

  if( hb_pcount() == 1 && ISOBJECT(1) )
  {
    PHB_ITEM ptr = hb_itemPutPtr( NULL, (void *) hb_itemGetPtr( hb_objSendMsg( hb_param(1, HB_IT_OBJECT ), "POINTER", 0 ) ) );
    hb_objSendMsg( self, "_pointer", 1, ptr );
    hb_itemRelease( ptr );
    PHB_ITEM des = hb_itemPutL( NULL, false );
    hb_objSendMsg( self, "_self_destruction", 1, des );
    hb_itemRelease( des );
  }
  else if( hb_pcount() == 1 && ISPOINTER(1) )
  {
    PHB_ITEM ptr = hb_itemPutPtr( NULL, (void *) hb_itemGetPtr( hb_param(1, HB_IT_POINTER ) ) );
    hb_objSendMsg( self, "_pointer", 1, ptr );
    hb_itemRelease( ptr );
    PHB_ITEM des = hb_itemPutL( NULL, false );
    hb_objSendMsg( self, "_self_destruction", 1, des );
    hb_itemRelease( des );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( self );
}

HB_FUNC_STATIC( QTWIN_NEWFROMOBJECT )
{
  HB_FUNC_EXEC( QTWIN_NEWFROM );
}

HB_FUNC_STATIC( QTWIN_NEWFROMPOINTER )
{
  HB_FUNC_EXEC( QTWIN_NEWFROM );
}

HB_FUNC_STATIC( QTWIN_SELFDESTRUCTION )
{
  hb_retl( (bool) hb_itemGetL( hb_objSendMsg( hb_stackSelfItem(), "SELF_DESTRUCTION", 0 ) ) );
}

HB_FUNC_STATIC( QTWIN_SETSELFDESTRUCTION )
{
  PHB_ITEM self = hb_stackSelfItem();

  if( hb_pcount() == 1 && ISLOG(1) )
  {
    PHB_ITEM des = hb_itemPutL( NULL, hb_parl(1) );
    hb_objSendMsg( self, "_self_destruction", 1, des );
    hb_itemRelease( des );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( self );
}

#pragma ENDDUMP

/*

  Qt5xHb - Bindings libraries for Harbour/xHarbour and Qt Framework 5

  Copyright (C) 2018 Marcos Antonio Gambeta <marcosgambeta AT outlook DOT com>

*/

/*
  DO NOT EDIT THIS FILE - the content was created using a source code generator
*/

#include "hbclass.ch"

#ifndef QT5XHB_NO_REQUESTS
REQUEST QCOLOR
REQUEST QIMAGE
REQUEST QPIXMAP
REQUEST QREGION
#endif

CLASS QtWin

   DATA pointer
   DATA self_destruction INIT .F.

   METHOD createMask
   METHOD toHBITMAP
   METHOD fromHBITMAP
   METHOD toHICON
   METHOD imageFromHBITMAP
   METHOD fromHICON
   METHOD toHRGN
   METHOD fromHRGN
   METHOD stringFromHresult
   METHOD errorStringFromHresult
   METHOD colorizationColor
   METHOD realColorizationColor
   METHOD setWindowExcludedFromPeek
   METHOD isWindowExcludedFromPeek
   METHOD setWindowDisallowPeek
   METHOD isWindowPeekDisallowed
   METHOD setWindowFlip3DPolicy
   METHOD windowFlip3DPolicy
   METHOD extendFrameIntoClientArea
   METHOD resetExtendedFrame
   METHOD enableBlurBehindWindow
   METHOD disableBlurBehindWindow
   METHOD isCompositionEnabled
   METHOD setCompositionEnabled
   METHOD isCompositionOpaque
   METHOD setCurrentProcessExplicitAppUserModelID
   METHOD markFullscreenWindow
   METHOD taskbarActivateTab
   METHOD taskbarActivateTabAlt
   METHOD taskbarAddTab
   METHOD taskbarDeleteTab

   METHOD newFrom
   METHOD newFromObject
   METHOD newFromPointer
   METHOD selfDestruction
   METHOD setSelfDestruction

   DESTRUCTOR destroyObject

END CLASS

PROCEDURE destroyObject () CLASS QtWin
   IF ::self_destruction
      ::delete()
   ENDIF
RETURN

#pragma BEGINDUMP

#include <Qt>

#ifndef __XHARBOUR__
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#include <QtWin>
#endif
#endif

#include "qt5xhb_common.h"
#include "qt5xhb_macros.h"
#include "qt5xhb_utils.h"

#ifdef __XHARBOUR__
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#include <QtWin>
#endif
#endif

/*
static HBITMAP createMask(const QBitmap &bitmap)
*/
HB_FUNC_STATIC( QTWIN_CREATEMASK )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISQBITMAP(1) )
  {
      hb_retptr( (HBITMAP) QtWin::createMask ( *PQBITMAP(1) ) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static HBITMAP toHBITMAP(const QPixmap &p, HBitmapFormat format = HBitmapNoAlpha)
*/
HB_FUNC_STATIC( QTWIN_TOHBITMAP )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISBETWEEN(1,2) && ISQPIXMAP(1) && ISOPTNUM(2) )
  {
      hb_retptr( (HBITMAP) QtWin::toHBITMAP ( *PQPIXMAP(1), ISNIL(2)? (QtWin::HBitmapFormat) QtWin::HBitmapNoAlpha : (QtWin::HBitmapFormat) hb_parni(2) ) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static QPixmap fromHBITMAP(HBITMAP bitmap, HBitmapFormat format = HBitmapNoAlpha)
*/
HB_FUNC_STATIC( QTWIN_FROMHBITMAP )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISBETWEEN(1,2) && ISPOINTER(1) && ISOPTNUM(2) )
  {
      QPixmap * ptr = new QPixmap( QtWin::fromHBITMAP ( (HBITMAP) hb_parptr(1), ISNIL(2)? (QtWin::HBitmapFormat) QtWin::HBitmapNoAlpha : (QtWin::HBitmapFormat) hb_parni(2) ) );
      _qt5xhb_createReturnClass ( ptr, "QPIXMAP", true );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static HICON toHICON(const QPixmap &p)
*/
HB_FUNC_STATIC( QTWIN_TOHICON )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISQPIXMAP(1) )
  {
      hb_retptr( (HICON) QtWin::toHICON ( *PQPIXMAP(1) ) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static QImage imageFromHBITMAP(HDC hdc, HBITMAP bitmap, int width, int height)
*/
HB_FUNC_STATIC( QTWIN_IMAGEFROMHBITMAP )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(4) && ISPOINTER(1) && ISPOINTER(2) && ISNUM(3) && ISNUM(4) )
  {
      QImage * ptr = new QImage( QtWin::imageFromHBITMAP ( (HDC) hb_parptr(1), (HBITMAP) hb_parptr(2), PINT(3), PINT(4) ) );
      _qt5xhb_createReturnClass ( ptr, "QIMAGE", true );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static QPixmap fromHICON(HICON icon)
*/
HB_FUNC_STATIC( QTWIN_FROMHICON )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISPOINTER(1) )
  {
      QPixmap * ptr = new QPixmap( QtWin::fromHICON ( (HICON) hb_parptr(1) ) );
      _qt5xhb_createReturnClass ( ptr, "QPIXMAP", true );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static HRGN toHRGN(const QRegion &region)
*/
HB_FUNC_STATIC( QTWIN_TOHRGN )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISQREGION(1) )
  {
      hb_retptr( (HRGN) QtWin::toHRGN ( *PQREGION(1) ) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static QRegion fromHRGN(HRGN hrgn)
*/
HB_FUNC_STATIC( QTWIN_FROMHRGN )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISPOINTER(1) )
  {
      QRegion * ptr = new QRegion( QtWin::fromHRGN ( (HRGN) hb_parptr(1) ) );
      _qt5xhb_createReturnClass ( ptr, "QREGION", true );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static QString stringFromHresult(HRESULT hresult)
*/
HB_FUNC_STATIC( QTWIN_STRINGFROMHRESULT )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef Q_OS_WIN64
    if( ISNUMPAR(1) && ISPOINTER(1) )
  {
      RQSTRING( QtWin::stringFromHresult ( (HRESULT) hb_parptr(1) ) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static QString errorStringFromHresult(HRESULT hresult)
*/
HB_FUNC_STATIC( QTWIN_ERRORSTRINGFROMHRESULT )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
#ifndef Q_OS_WIN64
    if( ISNUMPAR(1) && ISPOINTER(1) )
  {
      RQSTRING( QtWin::errorStringFromHresult ( (HRESULT) hb_parptr(1) ) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
#endif
}

/*
static QColor colorizationColor(bool *opaqueBlend = 0)
*/
HB_FUNC_STATIC( QTWIN_COLORIZATIONCOLOR )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISBETWEEN(0,1) && ISOPTLOG(1) )
  {
     bool par1;
      QColor * ptr = new QColor( QtWin::colorizationColor ( &par1 ) );
      _qt5xhb_createReturnClass ( ptr, "QCOLOR", true );
     hb_storl( par1, 1 );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static QColor realColorizationColor()
*/
HB_FUNC_STATIC( QTWIN_REALCOLORIZATIONCOLOR )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(0) )
  {
      QColor * ptr = new QColor( QtWin::realColorizationColor () );
      _qt5xhb_createReturnClass ( ptr, "QCOLOR", true );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static void setWindowExcludedFromPeek(QWindow *window, bool exclude)
*/
HB_FUNC_STATIC( QTWIN_SETWINDOWEXCLUDEDFROMPEEK )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(2) && ISQWINDOW(1) && ISLOG(2) )
  {
      QtWin::setWindowExcludedFromPeek ( PQWINDOW(1), PBOOL(2) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static bool isWindowExcludedFromPeek(QWindow *window)
*/
HB_FUNC_STATIC( QTWIN_ISWINDOWEXCLUDEDFROMPEEK )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
      RBOOL( QtWin::isWindowExcludedFromPeek ( PQWINDOW(1) ) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static void setWindowDisallowPeek(QWindow *window, bool disallow)
*/
HB_FUNC_STATIC( QTWIN_SETWINDOWDISALLOWPEEK )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(2) && ISQWINDOW(1) && ISLOG(2) )
  {
      QtWin::setWindowDisallowPeek ( PQWINDOW(1), PBOOL(2) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static bool isWindowPeekDisallowed(QWindow *window)
*/
HB_FUNC_STATIC( QTWIN_ISWINDOWPEEKDISALLOWED )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
      RBOOL( QtWin::isWindowPeekDisallowed ( PQWINDOW(1) ) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static void setWindowFlip3DPolicy(QWindow *window, WindowFlip3DPolicy policy)
*/
HB_FUNC_STATIC( QTWIN_SETWINDOWFLIP3DPOLICY )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(2) && ISQWINDOW(1) && ISNUM(2) )
  {
      QtWin::setWindowFlip3DPolicy ( PQWINDOW(1), (QtWin::WindowFlip3DPolicy) hb_parni(2) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static WindowFlip3DPolicy windowFlip3DPolicy(QWindow *)
*/
HB_FUNC_STATIC( QTWIN_WINDOWFLIP3DPOLICY )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
      RENUM( QtWin::windowFlip3DPolicy ( PQWINDOW(1) ) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static void extendFrameIntoClientArea(QWindow *window, int left, int top, int right, int bottom)
*/
void QtWin_extendFrameIntoClientArea1 ()
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))

      QtWin::extendFrameIntoClientArea ( PQWINDOW(1), PINT(2), PINT(3), PINT(4), PINT(5) );

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void extendFrameIntoClientArea(QWindow *window, const QMargins &margins)
*/
void QtWin_extendFrameIntoClientArea2 ()
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))

      QtWin::extendFrameIntoClientArea ( PQWINDOW(1), *PQMARGINS(2) );

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

//[1]void extendFrameIntoClientArea(QWindow *window, int left, int top, int right, int bottom)
//[2]void extendFrameIntoClientArea(QWindow *window, const QMargins &margins)

HB_FUNC_STATIC( QTWIN_EXTENDFRAMEINTOCLIENTAREA )
{
  if( ISNUMPAR(5) && ISQWINDOW(1) && ISNUM(2) && ISNUM(3) && ISNUM(4) && ISNUM(5) )
  {
    QtWin_extendFrameIntoClientArea1();
  }
  else if( ISNUMPAR(2) && ISQWINDOW(1) && ISQMARGINS(2) )
  {
    QtWin_extendFrameIntoClientArea2();
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
}

/*
static void resetExtendedFrame(QWindow *window)
*/
HB_FUNC_STATIC( QTWIN_RESETEXTENDEDFRAME )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
      QtWin::resetExtendedFrame ( PQWINDOW(1) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void enableBlurBehindWindow(QWindow *window, const QRegion &region)
*/
void QtWin_enableBlurBehindWindow1 ()
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))

      QtWin::enableBlurBehindWindow ( PQWINDOW(1), *PQREGION(2) );

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void enableBlurBehindWindow(QWindow *window)
*/
void QtWin_enableBlurBehindWindow2 ()
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))

      QtWin::enableBlurBehindWindow ( PQWINDOW(1) );

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

//[1]void enableBlurBehindWindow(QWindow *window, const QRegion &region)
//[2]void enableBlurBehindWindow(QWindow *window)

HB_FUNC_STATIC( QTWIN_ENABLEBLURBEHINDWINDOW )
{
  if( ISNUMPAR(1) && ISQWINDOW(1) && ISQREGION(2) )
  {
    QtWin_enableBlurBehindWindow1();
  }
  else if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
    QtWin_enableBlurBehindWindow2();
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
}

/*
static void disableBlurBehindWindow(QWindow *window)
*/
HB_FUNC_STATIC( QTWIN_DISABLEBLURBEHINDWINDOW )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
      QtWin::disableBlurBehindWindow ( PQWINDOW(1) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static bool isCompositionEnabled()
*/
HB_FUNC_STATIC( QTWIN_ISCOMPOSITIONENABLED )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(0) )
  {
      RBOOL( QtWin::isCompositionEnabled () );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static void setCompositionEnabled(bool enabled)
*/
HB_FUNC_STATIC( QTWIN_SETCOMPOSITIONENABLED )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISLOG(1) )
  {
      QtWin::setCompositionEnabled ( PBOOL(1) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static bool isCompositionOpaque()
*/
HB_FUNC_STATIC( QTWIN_ISCOMPOSITIONOPAQUE )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(0) )
  {
      RBOOL( QtWin::isCompositionOpaque () );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
#endif
}

/*
static void setCurrentProcessExplicitAppUserModelID(const QString &id)
*/
HB_FUNC_STATIC( QTWIN_SETCURRENTPROCESSEXPLICITAPPUSERMODELID )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISCHAR(1) )
  {
      QtWin::setCurrentProcessExplicitAppUserModelID ( PQSTRING(1) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void markFullscreenWindow(QWindow *, bool fullscreen = true)
*/
HB_FUNC_STATIC( QTWIN_MARKFULLSCREENWINDOW )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISBETWEEN(1,2) && ISQWINDOW(1) && ISOPTLOG(2) )
  {
      QtWin::markFullscreenWindow ( PQWINDOW(1), OPBOOL(2,true) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void taskbarActivateTab(QWindow *)
*/
HB_FUNC_STATIC( QTWIN_TASKBARACTIVATETAB )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
      QtWin::taskbarActivateTab ( PQWINDOW(1) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void taskbarActivateTabAlt(QWindow *)
*/
HB_FUNC_STATIC( QTWIN_TASKBARACTIVATETABALT )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
      QtWin::taskbarActivateTabAlt ( PQWINDOW(1) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void taskbarAddTab(QWindow *)
*/
HB_FUNC_STATIC( QTWIN_TASKBARADDTAB )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
      QtWin::taskbarAddTab ( PQWINDOW(1) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

/*
static void taskbarDeleteTab(QWindow *)
*/
HB_FUNC_STATIC( QTWIN_TASKBARDELETETAB )
{
#if (QT_VERSION >= QT_VERSION_CHECK(5,2,0))
    if( ISNUMPAR(1) && ISQWINDOW(1) )
  {
      QtWin::taskbarDeleteTab ( PQWINDOW(1) );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( hb_stackSelfItem() );
#endif
}

HB_FUNC_STATIC( QTWIN_NEWFROM )
{
  PHB_ITEM self = hb_stackSelfItem();

  if( hb_pcount() == 1 && ISOBJECT(1) )
  {
    PHB_ITEM ptr = hb_itemPutPtr( NULL, (void *) hb_itemGetPtr( hb_objSendMsg( hb_param(1, HB_IT_OBJECT ), "POINTER", 0 ) ) );
    hb_objSendMsg( self, "_pointer", 1, ptr );
    hb_itemRelease( ptr );
    PHB_ITEM des = hb_itemPutL( NULL, false );
    hb_objSendMsg( self, "_self_destruction", 1, des );
    hb_itemRelease( des );
  }
  else if( hb_pcount() == 1 && ISPOINTER(1) )
  {
    PHB_ITEM ptr = hb_itemPutPtr( NULL, (void *) hb_itemGetPtr( hb_param(1, HB_IT_POINTER ) ) );
    hb_objSendMsg( self, "_pointer", 1, ptr );
    hb_itemRelease( ptr );
    PHB_ITEM des = hb_itemPutL( NULL, false );
    hb_objSendMsg( self, "_self_destruction", 1, des );
    hb_itemRelease( des );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( self );
}

HB_FUNC_STATIC( QTWIN_NEWFROMOBJECT )
{
  HB_FUNC_EXEC( QTWIN_NEWFROM );
}

HB_FUNC_STATIC( QTWIN_NEWFROMPOINTER )
{
  HB_FUNC_EXEC( QTWIN_NEWFROM );
}

HB_FUNC_STATIC( QTWIN_SELFDESTRUCTION )
{
  hb_retl( (bool) hb_itemGetL( hb_objSendMsg( hb_stackSelfItem(), "SELF_DESTRUCTION", 0 ) ) );
}

HB_FUNC_STATIC( QTWIN_SETSELFDESTRUCTION )
{
  PHB_ITEM self = hb_stackSelfItem();

  if( hb_pcount() == 1 && ISLOG(1) )
  {
    PHB_ITEM des = hb_itemPutL( NULL, hb_parl(1) );
    hb_objSendMsg( self, "_self_destruction", 1, des );
    hb_itemRelease( des );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }

  hb_itemReturn( self );
}

#pragma ENDDUMP