win32forth-cvs

[George H. <geo...@us...>]

Update of /cvsroot/win32forth/win32forth-stc/src/gdi
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13237/win32forth-stc/src/gdi

Added Files:
	gdiBase.f gdiPen.f gdiStruct.f gdiTools.f 
Log Message:
gah:Added some of the gdi functions updated primutil.f with extra utilities needed for GUI and bugfixes/extensions to class.f

--- NEW FILE: gdiBase.f ---
\ *D doc\classes\
\ *! gdiBase
\ *T gdiObject -- Base class for GDI objects
\ *Q Version 1.0
\ ** This GDI class library was written and placed in the Public Domain
\ ** in 2005 by Dirk Busch

\ *P gdiObject is the base class for all GDI objects.  This class
\ ** contains a single ivar, hObject, that is the (MS Windows) handle for the
\ ** GDI object. Since GdiObject is a generic class it should not be used to create
\ ** any instances. There will be the following subclasses of gdiObject:

\ *W <ul>
\ *W <li><a href="gdiPen.htm#gdiPen">gdiPen</a> Class for cosmetic pen's</li>
\ *W <li><a href="gdiPen.htm#gdiGeometricPen">gdiGeometricPen</a> Class for geometric pen's</li>

\ *W <li><a href="gdiBrush.htm#gdiSolidBrush">gdiSolidBrush</a> Solid brush class</li>
\ *W <li><a href="gdiBrush.htm#gdiHatchBrush">gdiHatchBrush</a> Hatch brush class</li>
\ *W <li><a href="gdiBrush.htm#gdiPatternBrush">gdiPatternBrush</a> Pattern brush class</li>
\ *W <li><a href="gdiBrush.htm#gdiDIBPatternBrush">gdiDIBPatternBrush</a> DIBPattern brush class</li>

\ *W <li><a href="gdiFont.htm">gdiFont</a> Class for windows fonts</li>

\ *W <li><a href="gdiBitmap.htm">gdiBitmap</a> Class for bitmaps</li>
\ *W <li><a href="gdiMetafile.htm">gdiMetafile</a> Class for enhanced metafiles</li>

\ *W <li><a href="gdiDC.htm">gdiDC</a> Base device context class</li>
\ *W <li><a href="gdiWindowDC.htm">gdiWindowDC</a> Device context class for windows</li>
\ *W <li><a href="gdiMetafileDC.htm">gdiMetafileDC</a> Device context class for enhanced metafiles</li>

\ *W </ul>

\ *P There are some other (old) classes in Win32Forth that are dealing with the GDI:
\ *L
\ *| ColorObject        | Class for color objects           |
\ *| ExtColorObject     | Class for extended color objects  |
\ *| HatchColorObject   | Class for hatch color objects     |
\ *| Font               | Class for fonts                   |
\ *| WinDC              | Device context class for windows  |
\ *| WinPrinter         | Device context class for printing |

\ *P All old classes are rewritten to use the GDI class library.

\ *S Glossary

cr .( Loading GDI class library - Base...)

needs gdiStruct.f
needs gdiTools.f

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Global linked list of gdi objects
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

internal

\ List of all GDI objects that are currently defined in the system.
VARIABLE gdi-object-link
         gdi-object-link OFF

external

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Base class for all GDI Objects
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:class gdiObject <super object
\ *G gdiObject is the base class for all GDI Object classes.

int hObject \ handle of the GDI object

:M ZeroHandle:  ( -- )
\ *G Clear the handle of the object. \n
\ ** If the current handle of the object is valid it will not be destroyed.
        0 to hObject ;M

:M ClassInit:   ( -- )
\ Init the class
        ClassInit: super

        ZeroHandle: self        \ zero handle
        gdi-object-link link,   \ link into list so we
        self ,                  \ can send ourself messages
        ;M

:M GetType:     ( -- n )
\ *G Get the type of the object.  \n
\ ** Possible return values are:
\ *L
\ *| OBJ_BITMAP         | Bitmap |
\ *| OBJ_BRUSH          | Brush |
\ *| OBJ_COLORSPACE     | Color space |
\ *| OBJ_DC             | Device context |
\ *| OBJ_ENHMETADC      | Enhanced metafile DC |
\ *| OBJ_ENHMETAFILE    | Enhanced metafile |
\ *| OBJ_EXTPEN         | Extended pen |
\ *| OBJ_FONT           | Font |
\ *| OBJ_MEMDC          | Memory DC |
\ *| OBJ_METAFILE       | Metafile |
\ *| OBJ_METADC         | Metafile DC |
\ *| OBJ_PAL            | Palette |
\ *| OBJ_PEN            | Pen |
\ *| OBJ_REGION         | Region |
        hObject call GetObjectType ;M

:M GetObject:   ( cbBuffer lpvObject -- n )
\ *G Get information for the object.      \n
\ ** If the function succeeds, and lpvObject is a valid pointer, the return value is
\ ** the number of bytes stored into the buffer. \n
\ ** If the function succeeds, and lpvObject is NULL, the return value is the number
\ ** of bytes required to hold the information the function would store into the buffer.
\ ** If the function fails, the return value is zero.
        hObject 3reverse call GetObject ;M

\ check if it's save to destroy the object
: Destroy?      ( -- f )
        GetType: self
             dup OBJ_PEN     =
        swap dup OBJ_EXTPEN  =
        swap dup OBJ_BRUSH   =
        swap dup OBJ_FONT    =
        swap dup OBJ_BITMAP  =
        swap dup OBJ_REGION  =
        swap     OBJ_PAL     =
        or or or or or or ;

:M Destroy:     ( -- )
\ *G Destroy the object.
        Destroy?
        if   hObject call DeleteObject drop \ ?win-error
        then 0 to hObject
        ;M

:M GetHandle:   ( -- hObject )
\ *G Get the handle of the object.
        hObject ;M

:M SetHandle:   ( hObject -- )
\ *G Set the handle of the object.      \n
\ ** If the current handle of the object is valid it will be destroyed.
        Destroy: self
        to hObject ;M

:M Valid?:      ( -- f )
\ *G Check if this object is valid.
        hObject 0<> ;M

\ ---------------- INTERNAL SYSTEM FUNCTIONS FOLLOW ----------------
\ The following functions and methods make sure that any gdi objects
\ created in your application get reset at system startup, and deleted
\ when Win32Forth closes.

in-system

: trim-gdi-objects ( nfa -- nfa )
        dup gdi-object-link full-trim ;

forget-chain chain-add trim-gdi-objects

in-application

: do-objects    { method -- }
        gdi-object-link @
        begin  dup
        while  dup cell+ @
               method execute
               @
        repeat drop ;

\ : init-gdi-objects      ( -- ) \ clear all handles
\         [getmethod] ZeroHandle: GdiObject do-objects ;

\ [getmethod] not yet implemented

: init-gdi-object       ( obj -- )
         ZeroHandle: GdiObject ;

: init-gdi-objects      ( -- ) \ clear all handles
         ['] init-gdi-object do-objects ;

:M destroy-gdi-objects: ( -- ) \ destory this object
        0 SetHandle: self ;M

: destroy-gdi-object    ( obj -- ) \ destroy a GDI object
        destroy-gdi-objects: GdiObject ;

: destroy-gdi-objects   ( -- ) \ destroy all GDI objects
        ['] destroy-gdi-object do-objects ;

initialization-chain chain-add init-gdi-objects
unload-chain         chain-add destroy-gdi-objects

;class
\ *G End of gdiBase class

\ *S Helper words outside the gdiBase class

: ?IsGdiObject  ( a1 -- f )                     \ w32f
\ *G Check if a1 is the address of a GdiObject.
        >r gdi-object-link @
        begin  dup
        while  dup cell+ @ r@ =  \ match this gdi object?
               if   drop rdrop true EXIT \ leave test, passed
               then @
        repeat drop
        rdrop false ;

: GetGdiObjectHandle  { GdiObject -- handle }   \ w32f
\ *G Check if GdiObject is the address of a valid GdiObject.
\ ** If so return the handle of the object.
        GdiObject ?IsGdiObject
        if   GetHandle: GdiObject
        else GdiObject
        then ;

in-system
((
: .gdi-objects  ( -- )                          \ w32f sys
\ *G Display GDI objects whitch are currently defined.
        gdi-object-link @
        begin  dup
        while  dup cell+ @
               cell - body> .NAME
               12 #tab space 12 ?cr
               @
        repeat drop ;
))
in-application

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ A utility word to check that an operation about to be performed is really
\ being done on a gdi object, helps prevent horrible crashes
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

in-system

: (?GdiCheck)   ( a1 -- a1 )                    \ w32f sys internal
\ *G Verify if a1 is the address of a GdiObject.
\ ** If a1 isn't the address of a GdiObject the application will be aborted.
        dup ?IsGdiObject 0=
        if   \ forth-io .rstack
             true Abort" This is not a GDI Object!"
        then ;

in-application

: ?GdiCheck     ( a1 -- a1 )                    \ w32f
\ *G Verify if a1 is the address of a GdiObject.
\ *P If a1 isn't the address of a GdiObject and the error checking is enabled
\ ** the application will be aborted.
\ *P NOTE: \i ?GdiCheck \d does nothing in turnkey applications, it's for debugging only.
\        TURNKEYED? ?win-error-enabled 0= or ?EXIT \ leave if error checking is not enabled
\in-system-ok   (?GdiCheck) ;

module

\ *Z


--- NEW FILE: gdiTools.f ---
\ *! gdiTools
\ *T GdiTools -- Helper words for the GDI class library
\ *Q Version 1.0
\ ** This GDI class library was written and placed in the Public Domain
\ ** in 2005 by Dirk Busch
\ *S Glossary

cr .( Loading GDI class library - Tools...)

internal
external

in-application

[undefined] S-REVERSE [IF] \ from toolset.f
CODE S-REVERSE ( n[k]..2 1 0 k -- 0 1 2..n[k] ) \ w32f
\ *G Reverse n items on stack   \n
\ ** Usage: 1 2 3 4 5 5 S_REVERSE ==> 5 4 3 2 1
         lea     ecx, -4 [ebp]     \ ecx points 4 under top of stack
         lea     eax, 4 [ecx] [eax*4] \ eax points 4 over stack
\ bump pointers, if they overlap, stop
@@1:     sub     eax, # 4          \ adjust top
         add     ecx, # 4          \ adjust bottom
         cmp     ecx, eax          \ compare
         jae     short @@2         \ ecx passing eax, so exit
\ rotate a pair
\ xor a,b xor b,a xor a,b swaps a and b
         mov     edx, 0 [eax]      \ bottom to edx
         xor     0 [ecx], edx      \ exchange top and edx
         xor     edx,  0 [ecx]
         xor     0 [ecx], edx
         mov     0 [eax], edx      \ edx to bottom
         jmp     short @@1         \ next pair
@@2:     mov     eax, 0 [ebp]      \ tos
         lea     ebp, 4 [ebp]
         next    c;
[then]

[undefined] 3reverse [if]
: 3reverse ( n1 n2 n3 -- n3 n2 n1 ) \ w32f
\ *G Reverse 3 items on stack
        3 S-REVERSE ;
[then]

[undefined] 4reverse [if]
: 4reverse ( n1 n2 n3 n4 -- n4 n3 n2 n1 ) \ w32f
\ *G Reverse 4 items on stack
        4 S-REVERSE ;
[then]

[undefined] 5reverse [if]
: 5reverse ( n1 n2 n3 n4 n5 -- n5 n4 n3 n2 n1 ) \ w32f
\ *G Reverse 5 items on stack
        5 S-REVERSE ;
[then]

[undefined] 6reverse [if]
: 6reverse ( n1 n2 n3 n4 n5 n6 -- n6 n5 n4 n3 n2 n1 ) \ w32f
\ *G Reverse 6 items on stack
        6 S-REVERSE ;
[then]

[undefined] 8reverse [if]
: 8reverse ( n1 n2 n3 n4 n5 n6 n7 n8 -- n8 n7 n6 n5 n4 n3 n2 n1 ) \ w32f
\ *G Reverse 8 items on stack
        8 S-REVERSE ;
[then]

module

\ *Z

--- NEW FILE: gdiStruct.f ---
\ *D doc\classes\
\ *! gdiStruct
\ *T gdiStruct -- Wrapper classes for GDI structs.
\ *Q Version 1.0
\ ** This GDI class library was written and placed in the Public Domain
\ ** in 2005 by Dirk Busch

cr .( Loading GDI class library - Structs...)

Library COMDLG32.DLL

internal

create CustomColors 64 allot \ hold the userdefined custom colors

\ init custom colors
0xE6FFFF CustomColors        !  0xFFE6FF CustomColors 0x04 + !  0xFFFFE6 CustomColors 0x08 + !
0xFFE6E6 CustomColors 0x0C + !  0xE6FFE6 CustomColors 0x10 + !  0xE6E6FF CustomColors 0x14 + !
0xC8F0F0 CustomColors 0x18 + !  0xF0C8F0 CustomColors 0x1C + !  0xF0F0C8 CustomColors 0x20 + !
0xF0C8C8 CustomColors 0x24 + !  0xC8F0C8 CustomColors 0x28 + !  0xC8C8F0 CustomColors 0x2C + !
0xF0F0F0 CustomColors 0x30 + !  0xE6E6E6 CustomColors 0x34 + !  0xF4FFFF CustomColors 0x38 + !
0xFFFFF4 CustomColors 0x3C + !

external

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ *W <a name="gdiPOINT"></a>
\ *S gdiPOINT class
:class gdiPOINT <super object
\ *G Wrapper class for a POINT struct.
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Record: &POINT
        int x
        int y
;RecordSize: sizeof(POINT)

:M ClassInit:   ( -- )
        ClassInit: super

        0 to x
        0 to y
        ;M

:M GetX:        ( -- x )
\ *G Get the x value of the point.
                x ;M

:M GetY:        ( -- y )
\ *G Get the y value of the point.
                y ;M

:M SetX:        ( x -- )
\ *G Set the x value of the point.
                to x ;M

:M SetY:        ( y -- )
\ *G Get the y value of the point.
                to y ;M

:M Addr:        ( -- addr )
\ *G Get the address of the point struct.
                &POINT ;M

:M Size:        ( -- size )
\ *G Get the site of the point struct
                sizeof(POINT) ;M

;class
\ *G End of gdiPOINT class

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ *W <a name="gdiCOLORREF"></a>
\ *S gdiCOLORREF class
:class gdiCOLORREF <super object
\ *G Wrapper class for a COLORREF struct.
\ *P A COLORREF value is used to specify an RGB color.
\ *P When specifying an explicit RGB color, the COLORREF value has the following
\ ** hexadecimal form: 0x00bbggrr \n
\ ** The low-order byte contains a value for the relative intensity of red;
\ ** the second byte contains a value for green; and the third byte contains a
\ ** value for blue. The high-order byte must be zero. The maximum value for a
\ ** single byte is 0xFF.
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Record: &COLORREF
        byte r
        byte g
        byte b
        byte reserved
;RecordSize: sizeof(COLORREF)

Record: &CHOOSECOLOR
        int lStructSize
        int hwndOwner
        int hInstance
        int rgbResult
        int lpCustColors
        int Flags
        int lCustData
        int lpfnHook
        int lpTemplateName
;RecordSize: sizeof(CHOOSECOLOR)

:M ClassInit:   ( -- )
        ClassInit: super

        \ init &COLOR record
        0 to r
        0 to g
        0 to b
        0 to reserved

        \ init &CHOOSECOLOR record
        sizeof(CHOOSECOLOR) to lStructSize
        CustomColors        to lpCustColors
        [ CC_ANYCOLOR CC_FULLOPEN or CC_RGBINIT or ] literal to Flags
        null to hwndOwner
        null to hInstance
        0    to rgbResult
        0    to lCustData
        null to lpfnHook
        null to lpTemplateName

        ;M

:M SetRValue:   ( r -- )
\ *G Set the red value of the color
        to r ;M

:M SetGValue:   ( g -- )
\ *G Set the green value of the color
        to g ;M

:M SetBValue:   ( b -- )
\ *G Set the blue value of the color
        to b ;M

:M GetRValue:   ( -- r )
\ *G Get the red value of the color
        r ;M

:M GetGValue:   ( -- g )
\ *G Get the green value of the color
        g ;M

:M GetBValue:   ( -- b )
\ *G Get the blue value of the color
        b ;M

:M SetColor:    ( colorref -- )
\ *G Set the color
        0x00ffffff and &COLORREF ! ;M

:M SetSysColor: ( n -- )
\ *G Set a system color. Possible values are:
\ *L
\ *| COLOR_3DDKSHADOW | Dark shadow for three-dimensional display elements. |
\ *| COLOR_3DFACE, COLOR_BTNFACE | Face color for three-dimensional display elements and for dialog box backgrounds. |
\ *| COLOR_3DHILIGHT | Highlight color for three-dimensional display elements (for edges facing the light source.) |
\ *| COLOR_3DHIGHLIGHT | Highlight color for three-dimensional display elements (for edges facing the light source.) |
\ *| COLOR_BTNHILIGHT | Highlight color for three-dimensional display elements (for edges facing the light source.) |
\ *| COLOR_BTNHIGHLIGHT | Highlight color for three-dimensional display elements (for edges facing the light source.) |
\ *| COLOR_3DLIGHT | Light color for three-dimensional display elements (for edges facing the light source.) |
\ *| COLOR_3DSHADOW, COLOR_BTNSHADOW | Shadow color for three-dimensional display elements (for edges facing away from the light source). |
\ *| COLOR_ACTIVEBORDER | Active window border. |
\ *| COLOR_ACTIVECAPTION | Active window title bar. Windows 98, Windows 2000: Specifies the left side color in the color gradient of an active window's title bar if the gradient effect is enabled. |
\ *| COLOR_APPWORKSPACE | Background color of multiple document interface (MDI) applications. |
\ *| COLOR_BACKGROUND, COLOR_DESKTOP | Desktop. |
\ *| COLOR_BTNTEXT | Text on push buttons. |
\ *| COLOR_CAPTIONTEXT | Text in caption, size box, and scroll bar arrow box. |
\ *| COLOR_GRADIENTACTIVECAPTION | Windows 98, Windows 2000: Right side color in the color gradient of an active window's title bar.
\ *| COLOR_ACTIVECAPTION | Windows 98, Windows 2000: specifies the left side color.
\ *| COLOR_GRADIENTINACTIVECAPTION | Windows 98, Windows 2000: Right side color in the color gradient of an inactive window's title bar.
\ *| COLOR_INACTIVECAPTION | Windows 98, Windows 2000: specifies the left side color. |
\ *| COLOR_GRAYTEXT | Grayed (disabled) text. This color is set to 0 if the current display driver does not support a solid gray color. |
\ *| COLOR_HIGHLIGHT | Item(s) selected in a control. |
\ *| COLOR_HIGHLIGHTTEXT | Text of item(s) selected in a control. |
\ *| COLOR_HOTLIGHT | Windows 98, Windows 2000: Color for a hot-tracked item. Single clicking a hot-tracked item executes the item. |
\ *| COLOR_INACTIVEBORDER | Inactive window border. |
\ *| COLOR_INACTIVECAPTION | Inactive window caption. Windows 98, Windows 2000: Specifies the left side color in the color gradient of an inactive window's title bar if the gradient effect is enabled. |
\ *| COLOR_INACTIVECAPTIONTEXT | Color of text in an inactive caption. |
\ *| COLOR_INFOBK | Background color for tooltip controls. |
\ *| COLOR_INFOTEXT | Text color for tooltip controls. |
\ *| COLOR_MENU | Menu background. |
\ *| COLOR_MENUTEXT | Text in menus. |
\ *| COLOR_SCROLLBAR | Scroll bar gray area. |
\ *| COLOR_WINDOW | Window background. |
\ *| COLOR_WINDOWFRAME | Window frame. |
\ *| COLOR_WINDOWTEXT | Text in windows. |
        call GetSysColor &COLORREF ! ;M

:M GetColor:    ( -- colorref )
\ *G Get the color
        &COLORREF @ ;M

:M SetRGB:      ( r g b -- )
\ *G Set the red, green and blue values of the color
        SetBValue: self SetGValue: self SetRValue: self ;M

:M Addr:        ( -- addr )
\ *G Get the address of the COLORREF struct
        &COLORREF ;M

:M Size:        ( -- size )
\ *G Get the size of the COLORREF struct
        sizeof(COLORREF) ;M

:M Choose:      ( hWnd -- f )
\ *G Open the windows dialog for choosing a color.
        to hwndOwner
        GetColor: self to rgbResult
        &CHOOSECOLOR call ChooseColor
        IF   rgbResult SetColor: self true
        else false
        then ;M

\ return address and length of the user defined custom colors
:M CustomColors:        ( -- addr len )
\ *G Get the address and length (in cells) of the CustomColors array
\ ** used by Choose:
        CustomColors 64 ;M

;class
\ *G End of gdiCOLORREF class

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ *W <a name="gdiRGBQUAD"></a>
\ *S gdiRGBQUAD class
:class gdiRGBQUAD <super gdiCOLORREF
\ *G Wrapper class for a RGBQUAD struct
\ *P The RGBQUAD structure describes a color consisting of relative
\ ** intensities of red, green, and blue.
\ *P The bmiColors member of the BITMAPINFO structure consists of an array
\ ** of RGBQUAD structures.
\ *P Note: This class doesn't have any private methods. For a description
\ ** of the methods see the \i gdiCOLORREF \d class.
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:M ClassInit:   ( -- )
        ClassInit: super
        ;M

;class
\ *G End of gdiRGBQUAD class

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ *W <a name="gdiSIZE"></a>
\ *S gdiSIZE class
:class gdiSIZE <super object
\ *G Wrapper class for a SIZE struct
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Record: &SIZE
        int cx
        int cy
;RecordSize: sizeof(SIZE)

:M ClassInit:   ( -- )
        ClassInit: super

        0 to cx
        0 to cy
        ;M

:M GetX:        ( -- x )
\ *G Get the x value
        cx ;M

:M GetY:        ( -- y )
\ *G Get the y value
        cy ;M

:M SetX:        ( x -- )
\ *G Set the x value
        to cx ;M

:M SetY:        ( y -- )
\ *G Set the y value
        to cy ;M

:M Addr:        ( -- addr )
\ *G Get the address of the SIZE struct
        &SIZE ;M

:M Size:        ( -- size )
\ *G Get the size of the SIZE struct
        sizeof(SIZE) ;M

;class
\ *G End of gdiSIZE class

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ *W <a name="gdiTEXTMETRIC"></a>
\ *S gdiTEXTMETRIC class
:class gdiTEXTMETRIC <super object
\ *G Wrapper class for a TEXTMETRIC struct
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

Record: &TEXTMETRIC
        int  tmHeight
        int  tmAscent
        int  tmDescent
        int  tmInternalLeading
        int  tmExternalLeading
        int  tmAveCharWidth
        int  tmMaxCharWidth
        int  tmWeight
        int  tmOverhang
        int  tmDigitizedAspectX
        int  tmDigitizedAspectY
        byte tmFirstChar
        byte tmLastChar
        byte tmDefaultChar
        byte tmBreakChar
        byte tmItalic
        byte tmUnderlined
        byte tmStruckOut
        byte tmPitchAndFamily
        byte tmCharSet
;RecordSize: sizeof(TEXTMETRIC)

:M ClassInit:   ( -- )
        ClassInit: super
        &TEXTMETRIC sizeof(TEXTMETRIC) erase
        ;M

:M SetHeight:            ( n -- )
\ *G
        to tmHeight ;M

:M SetAscent:            ( n -- )
\ *G
        to tmAscent ;M

:M SetDescent:           ( n -- )
\ *G
        to tmDescent ;M

:M SetInternalLeading:   ( n -- )
\ *G
        to tmInternalLeading ;M

:M SetExternalLeading:   ( n -- )
\ *G
        to tmExternalLeading ;M

:M SetAveCharWidth:      ( n -- )
\ *G
        to tmAveCharWidth ;M

:M SetMaxCharWidth:      ( n -- )
\ *G
        to tmMaxCharWidth ;M

:M SetWeight:            ( n -- )
\ *G
        to tmWeight ;M

:M SetOverhang:          ( n -- )
\ *G
        to tmOverhang ;M

:M SetDigitizedAspectX:  ( n -- )
\ *G
        to tmDigitizedAspectX ;M

:M SetDigitizedAspectY:  ( n -- )
\ *G
        to tmDigitizedAspectY ;M

:M SetFirstChar:         ( n -- )
\ *G
        to tmFirstChar ;M

:M SetLastChar:          ( n -- )
\ *G
        to tmLastChar ;M

:M SetDefaultChar:       ( n -- )
\ *G
        to tmDefaultChar ;M

:M SetBreakChar:         ( n -- )
\ *G
        to tmBreakChar ;M

:M SetItalic:            ( n -- )
\ *G
        to tmItalic ;M

:M SetUnderlined:        ( n -- )
\ *G
        to tmUnderlined ;M

:M SetStruckOut:         ( n -- )
\ *G
        to tmStruckOut ;M

:M SetPitchAndFamily:    ( n -- )
\ *G
        to tmPitchAndFamily ;M

:M SetCharSet:           ( n -- )
\ *G
        to tmCharSet ;M

:M GetHeight:            ( -- n )
\ *G
        tmHeight ;M

:M GetAscent:            ( -- n )
\ *G
        tmAscent ;M

:M GetDescent:           ( -- n )
\ *G
        tmDescent ;M

:M GetInternalLeading:   ( -- n )
\ *G
        tmInternalLeading ;M

:M GetExternalLeading:   ( -- n )
\ *G
        tmExternalLeading ;M

:M GetAveCharWidth:      ( -- n )
\ *G
        tmAveCharWidth ;M

:M GetMaxCharWidth:      ( -- n )
\ *G
        tmMaxCharWidth ;M

:M GetWeight:            ( -- n )
\ *G
        tmWeight ;M

:M GetOverhang:          ( -- n )
\ *G
        tmOverhang ;M

:M GetDigitizedAspectX:  ( -- n )
\ *G
        tmDigitizedAspectX ;M

:M GetDigitizedAspectY:  ( -- n )
\ *G
        tmDigitizedAspectY ;M

:M GetFirstChar:         ( -- n )
\ *G
        tmFirstChar ;M

:M GetLastChar:          ( -- n )
\ *G
        tmLastChar ;M

:M GetDefaultChar:       ( -- n )
\ *G
        tmDefaultChar ;M

:M GetBreakChar:         ( -- n )
\ *G
        tmBreakChar ;M

:M GetItalic:            ( -- n )
\ *G
        tmItalic ;M

:M GetUnderlined:        ( -- n )
\ *G
        tmUnderlined ;M

:M GetStruckOut:         ( -- n )
\ *G
        tmStruckOut ;M

:M GetPitchAndFamily:    ( -- n )
\ *G
        tmPitchAndFamily ;M

:M GetCharSet:           ( -- n )
\ *G
        tmCharSet ;M

:M Addr:                 ( -- addr ) &TEXTMETRIC ;M
\ *G Get the address of the TEXTMETRIC struct.

:M Size:                 ( -- size ) sizeof(TEXTMETRIC) ;M
\ *G Get the size of the TEXTMETRIC struct.

;class
\ *G End of gdiTEXTMETRIC class

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ The LOGPEN structure defines the style, width, and color of a pen.
\ The CreatePenIndirect function uses the LOGPEN structure.
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ :struct LOGPEN
\     UINT     lopnStyle
\     int      lopnWidth
\     int      lopnReserved
\     COLORREF lopnColor
\ ;struct

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ The LOGBRUSH structure defines the style, color, and pattern of a physical
\ brush. It is used by the CreateBrushIndirect and ExtCreatePen functions.
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

\ :struct LOGBRUSH
\   UINT     lbStyle
\   COLORREF lbColor
\   LONG     lbHatch
\ ;struct

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ BITMAP struct
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

\ :struct BITMAP
\   LONG   bmType         \ Specifies the bitmap type. This member must be zero.
\   LONG   bmWidth        \ Specifies the width, in pixels, of the bitmap.
\                         \ The width must be greater than zero.
\   LONG   bmHeight       \ Specifies the height, in pixels, of the bitmap.
\                         \ The height must be greater than zero.
\   LONG   bmWidthBytes   \ Specifies the number of bytes in each scan line.
\                         \ This value must be divisible by 2, because the system
\                         \ assumes that the bit values of a bitmap form an array
\                         \ that is word aligned.
\   WORD   bmPlanes       \ Specifies the count of color planes.
\   WORD   bmBitsPixel    \ Specifies the number of bits required to indicate the
\                         \ color of a pixel.
\   LPVOID bmBits         \ Pointer to the location of the bit values for the bitmap.
\                         \ The bmBits member must be a long pointer to an array of
\                         \ character (1-byte) values.
\ ;struct

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ BITMAPINFOHEADER struct
\
\ The BITMAPINFOHEADER structure contains information about the dimensions
\ and color format of a DIB.
\
\ Applications developed for Windows NT 4.0 and Windows 95 may use the
\ BITMAPV4HEADER structure. Applications developed for Windows 2000 and
\ Windows 98 may use the BITMAPV5HEADER structure for increased functionality.
\ However, these can be used only in the CreateDIBitmap function.
\
\ NOTE: BITMAPV4HEADER and BITMAPV5HEADER are not supprted !!!
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

\ :struct BITMAPINFOHEADER
\   DWORD  biSize
\   LONG   biWidth
\   LONG   biHeight
\   WORD   biPlanes
\   WORD   biBitCount
\   DWORD  biCompression
\   DWORD  biSizeImage
\   LONG   biXPelsPerMeter
\   LONG   biYPelsPerMeter
\   DWORD  biClrUsed
\   DWORD  biClrImportant
\ ;struct

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ ENHMETAHEADER struct
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

\ :struct ENHMETAHEADER
\   DWORD iType
\   DWORD nSize
\   RECTL rclBounds
\   RECTL rclFrame
\   DWORD dSignature
\   DWORD nVersion
\   DWORD nBytes
\   DWORD nRecords
\   WORD  nHandles
\   WORD  sReserved
\   DWORD nDescription
\   DWORD offDescription
\   DWORD nPalEntries
\   SIZEL szlDevice
\   SIZEL szlMillimeters
\   DWORD cbPixelFormat
\   DWORD offPixelFormat
\   DWORD bOpenGL
\   SIZEL szlMicrometers
\ ;struct

module

\ *Z

--- NEW FILE: gdiPen.f ---

\ *D doc\classes\
\ *! gdiPen
\ *T GdiPen -- Class for GDI Pens
\ *Q Version 1.0
\ ** This GDI class library was written and placed in the Public Domain
\ ** in 2005 by Dirk Busch

\ TODO: finish gdiGeometricPen class

cr .( Loading GDI class library - Pen...)

needs gdiBase.f

internal
external

\ ----------------------------------------------------------------------
\ ----------------------------------------------------------------------
\ *W <a name="gdiPen"></a>
\ *S gdiPen class
:class gdiPen <super gdiObject
\ *G Class for cosmetic pen's

\ Syle of the pen.
int Style

\ Width of the pen, in logical units. If Width is zero, the pen is a single pixel
\ wide, regardless of the current transformation.
int Width

\ Color of the pen.
gdiCOLORREF Color

:M ClassInit:   ( -- )
\ *G Init the class
        ClassInit: super

        PS_SOLID to Style
        1 to Width
        ;M

:M SetStyle:    ( style -- )
\ *G Set Syle of the pen. Possible values are:
\ *L
\ *| PS_SOLID       | The pen is solid. |
\ *| PS_DASH        | The pen is dashed. This style is valid only when the pen width is one or less in device units. |
\ *| PS_DOT         | The pen is dotted. This style is valid only when the pen width is one or less in device units. |
\ *| PS_DASHDOT     | The pen has alternating dashes and dots. This style is valid only when the pen width is one or less in device units. |
\ *| PS_DASHDOTDOT  | The pen has alternating dashes and double dots. This style is valid only when the pen width is one or less in device units. |
\ *| PS_NULL        | The pen is invisible. |
\ *| PS_INSIDEFRAME | The pen is solid. When this pen is used the dimensions of the figure are shrunk so that it fits entirely in the bounding rectangle, taking into account the width of the pen. Only for geometric pens. |
        to style ;M

:M SetWidth:    ( width -- )
\ *G Set the width of the pen in logical units. If Width is zero, the pen is a single pixel
\ ** wide, regardless of the current transformation.
    0 max to width ;M

:M SetRValue:   ( r -- )
\ *G Set the red component of the pen color.
        SetRValue: Color ;M

:M SetGValue:   ( g -- )
\ *G Set the green component of the pen color.
        SetGValue: Color ;M

:M SetBValue:   ( b -- )
\ *G Set the blue component of the pen color.
        SetBValue: Color ;M

:M SetRGB:      ( r g b -- )
\ *G Set the red, green and blue component of the pen color.
        SetRGB: Color ;M

:M SetColor:    ( colorref -- )
\ *G Set color of the pen.
        SetColor: Color ;M

:M SetSysColor: ( n -- )
\ *G Set the color of the pen to a system color.
        SetSysColor: Color ;M

:M ChooseColor: ( hWnd -- f )
\ *G Open a dialog to choose the color of the pen.
        Choose: Color ;M

:M GetStyle:    ( -- style )
\ *G Get Syle of the pen. Possible values are:
\ *L
\ *| PS_SOLID       | The pen is solid. |
\ *| PS_DASH        | The pen is dashed. This style is valid only when the pen width is one or less in device units. |
\ *| PS_DOT         | The pen is dotted. This style is valid only when the pen width is one or less in device units. |
\ *| PS_DASHDOT     | The pen has alternating dashes and dots. This style is valid only when the pen width is one or less in device units. |
\ *| PS_DASHDOTDOT  | The pen has alternating dashes and double dots. This style is valid only when the pen width is one or less in device units. |
\ *| PS_NULL        | The pen is invisible. |
\ *| PS_INSIDEFRAME | The pen is solid. When this pen is used the dimensions of the figure are shrunk so that it fits entirely in the bounding rectangle, taking into account the width of the pen. This applies only to geometric pens. |
        style ;M

:M GetWidth:    ( -- width )
\ *G Get the width of the pen in logical units. If the width is zero, the pen is a single pixel
\ ** wide, regardless of the current transformation.
        width ;M

:M GetRValue:   ( -- r )
\ *G Get the red component of the pen color.
        GetRValue: Color ;M

:M GetGValue:   ( -- g )
\ *G Get the green component of the pen color.
        GetGValue: Color ;M

:M GetBValue:   ( -- b )
\ *G Get the blue component of the pen color.
        GetBValue: Color ;M

:M GetColor:    ( -- colorref )
\ *G Get the color of the pen as a windows COLORREF value.
        GetColor: Color ;M

:M Create:      ( -- f )
\ *G Create the pen with the current style, color and width.
        GetColor: color width style call CreatePen SetHandle: super
        Valid?: super ;M

:M CreateIndirect: ( pLogpen -- f )
\ *G The CreateIndirect function creates a logical cosmetic pen that
\ ** has the style, width, and color specified in a structure.
        dup           @ SetStyle: self
        dup   cell+   @ SetWidth: self
        dup 3 cells + @ SetColor: self
        call CreatePenIndirect SetHandle: super
        Valid?: super ;M

;class
\ *G End of class

\ ----------------------------------------------------------------------
\ ----------------------------------------------------------------------
\ *W <a name="gdiGeometricPen"></a>
\ *S gdiGeometricPen class
:class gdiGeometricPen <super gdiObject
\ *G Class for geometric pen's   \n
\ ** Note: this class isn't implemented yet

:M ClassInit:   ( -- )
\ *G Init the class
        ClassInit: super
        ;M

;class
\ *G End of class

module

\ *Z