\ ----------------------
\ ***** GDefault.f *****
\ ----------------------
{  TBG.f and CSG.f Version 1.0
   Text Boolean Gadgets and String/Integer gadget creation helper.

   by Marc Lupien,  Montreal, Canada.
   June of 1988
   CIS user no. 71550,640
}
{
Words to init misc gadget-related structures and do some other stuff too
  for the Complete_String/Boolean_Gadgets tools...
  C.F. files CSG.f, TBG.f
}

cr ." loading GDefault.f..." cr  decimal

anew GDefault_F

\ allot a struct and leave it's addesss
\ always allocate an even number of bytes (for boundaries)
\ and erase the allocated portion.

: AllotStruct   ( StructureLen -- StructAddrs )
	=cells		\ make shure this is an even number of bytes
	here locals| Start Len |
	Len allot
	Start Len erase
	Start ;

\ -------------------
\ ***** GADGETS *****
\ -------------------

: AllotGadget   ( ggActivation\ggGadgetType -- GadgetAddrs )
	Locals| ggType ggActiv |
	Gadget AllotStruct
	GADGHCOMP over +ggFlags	w!
	ggType  over +ggGadgetType	w!
	ggActiv over +ggActivation	w! ;

: CreateGadget   ( ggActivation\ggGadgetType -- GadgetAddrs )
	2 needed	\ check stack depth
	?exec		\ exec state only
	create		\ create it in dictionary
	AllotGadget ;	\ allocate it...


: setTop\Left\ID   ( Gadget\top\left\id -- GadgetAddrs )
	4 needed ?exec		\ check stack depth and exec state
	locals| id left top |
	id   over +ggGadgetID w!
	left over +ggLeftEdge w!
	top  over +ggTopEdge  w! ; immediate


: ggWidth\Height   ( GadgetAddrs -- ggWidth\ggHeight ) \ get Width & height
	dup  +ggWidth w@
	swap +ggHeight w@ ;


: StrGadget?   ( GadgetAddrs -- flag ) \ is it a String or Integer gadget
	+ggGadgetType w@ STRGADGET = ;

\ ----------------------
\ ***** STRINGINFO *****
\ ----------------------

: AllotStringInfo   ( siMaxChars-- StringInfoAddr )
	StringInfo AllotStruct
	swap over +siMaxChars w! ;

: R!siBuffers   ( Buffer\UndoBuffer\siStruct -- )
	locals| si |	\ StringInfo
	si +siUndoBuffer R!	\ with relocation...
	si +siBuffer R! ;


\ ---------------------
\ ***** INTUITEXT *****
\ ---------------------

: AllotIntuiText   ( FrontPen -- itStruct )
	IntuiText AllotStruct
	JAM1 over +itDrawMode c!
	swap over +itFrontPen c! ;

\ get next in-line quoted string, put it in the dictionnary and
\ link it back to an IntuiText structure and leave the length
\ of the quoted in-line string.

: AllotIText"   ( ITstruct -- ITextLen )  ( <text>" )
	0 0 0 locals| Text Tlen IText ITstruct |
	34 ?word count to Tlen to Text  \ get <Text>"
	Tlen 1+ AllotStruct to IText	\ allot space
	Text IText Tlen cmove		\ move string in dictionnary
	   0 IText Tlen + c!		\ end string with a null
	IText ITstruct +itIText R!	\ link IText -> ITstruct
	Tlen ;

\ ------------------
\ ***** BORDER *****
\ ------------------

: AllotBorder   ( FrontPen -- bdStruct )
	Border AllotStruct
	JAM1 over +bdDrawMode c!
	swap over +bdFrontPen c! ;

\ ------------------------
\ ***** BORDER PAIRS *****
\ ------------------------
{ The main idea:

  There should be more details in here but I am shure you can figure out
  the things I left out for yourself.

  -The size of a border is proportional to the size of the related
   gadget's select box e.g. +ggWidth, +ggHeight.

  -A border design is a set of pairs (X/Y coordinates). Each of these
   X or Y values can be one of the following :
	a) an absolute value (positive or negative),
	b) the width of the select box + an absolute value,
	   again positive or negative,
	c) the Height of the select box + an absolute value,
	   again positive or negative.

  -So to ease the allocation of a border design for a particular gadget,
   we create a table (called here a PairData table...) for each different
   design this way :
	create <PairDataName>	\ give a name for it
	<p> w,			\ number of pairs defined
	<code X1> w,	<cX1> w,	<code Y1> w,	<cY1> w,
	<code X2> w,	<cX2> w,	<code Y2> w,	<cY2> w,
	.
	.
	.
	<code Xp> w,	<cXp> w,	<code Yp> w,	<cYp> w,

  -Then Using AllotPairs with the rights parameters will do the trick.
}
	\ the codes for valid PairData opcode data

	0 constant paABS	\ code for absolute value
	1 constant paHeight+	\ code for Height + constant
	2 constant paWidth+	\ code for Width  + constant

\ low level part...
: <AllotPairs>   ( PairData\Width\Height -- NbOfPairs )
	0 locals| NbOfPairs Height Width |
	dup w@ dup to NbOfPairs 2* 0
	DO 2+ dup @point	\ constant\code
	   CASE
		paABS OF ENDOF	\ do nothing, keep constant as is
		paHeight+ OF	\ add Height to constant
		   Height + Endof
		paWidth+  OF	\ add Width to constant
		   Width  + Endof
		1 abort" Invalid AllotPairs code data!!!"
	   ENDCASE
	   w,	\ stuff result in dictionnary
	   2+	\ skip enough for next @point
	LOOP
	drop NbOfPairs ;

\ High Level Part...
: AllotPairs   ( BorderStruct\PairData\GadetStruct -- )
	here locals| PairsAddrs |
	ggWidth\Height	\ get Width and Height
	<AllotPairs>	\ returns nb. of pairs
	over +bdCount c!
	PairsAddrs swap +bdXY R! ;

\ -----------------
\ ***** FONTS *****
\ -----------------
{  Font Height and Width globals used to compute the size of 
	the gadget area and the border.
   You can change this prior to define a gadget if you plan
	on using a font with a different size.
   This default is ok for Topaz 8.
}
  Global myFontHeight   8 to myFontHeight
  Global myFontWidth    8 to myFontWidth

\ -----------------------
\ ***** Pen Collors *****
\ -----------------------
 
  Global myErasePen     0 to myErasePen     \ use this color to erase
  Global myFrontPen     1 to myFrontPen     \ this is normal Pen color
  Global myHighLightPen 3 to myHighlightPen \ this is highlight Pen color