win32forth-cvs — CVS Commit List

[Win32forth-cvs] win32forth/src Dc.f,1.9,1.10 FONTS.F,1.5,1.6 paths.f,1.5,1.6

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13139/src

Modified Files:
	Dc.f FONTS.F paths.f 
Log Message:
- Added my GDI class library to the CVS
- WinDC and Font classes rewritten to use the GDI class library
- Added some demo's whitch are using the GDI class library

Index: Dc.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Dc.f,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -d -r1.9 -r1.10
*** Dc.f	17 Oct 2005 08:56:21 -0000	1.9
--- Dc.f	1 Nov 2005 12:21:40 -0000	1.10
***************
*** 13,129 ****
  in-application
  
! : NewStruct     ( n1 --- hstruct )
!         dup>r malloc dup r> erase ;
! 
! : DeleteStruct  ( hstruct -- )
!         release ;
  
!   8 value CHAR-WIDTH            \ Width of each character in pixels
!  14 value CHAR-HEIGHT           \ Height of each character in pixels
  
  
! :CLASS WinDC   <Super Object
  
- int hdc         \ Handle to the device context
- int tabbuf
- int tabcnt
- int tabwidth
  int currentfont
  
  Rectangle FillRect
  
- 40 constant deftabs
- 
- deftabs cells bytes tabarray
- 
- :M DefaultTabs: ( -- )
-         deftabs 0
-         ?DO     i 1+ tabwidth * char-width *
-                 tabarray i cells+ !             \ fill default tabs
-         LOOP
-         tabarray to tabbuf
-         deftabs  to tabcnt
-         ;M
- 
  :M ClassInit:   ( -- )
          ClassInit: super
!         8 to tabwidth
!         DefaultTabs: self
!         0        to hdc
!         ;M
! 
! :M SetTabs:     ( a1 n1 -- )    \ a1 is array of cells with offsets
!         to tabcnt
!         to tabbuf
!         ;M
! 
! :M SetTabSize:  ( n1 -- )
!         to tabwidth
!         DefaultTabs: self
!         ;M
! 
! :M GetTabSize:  ( -- n1 )
!         tabwidth
          ;M
  
! :M GetHandle:   ( -- hdc )  hdc  ;M
! 
! :M PutHandle:   ( hdc -- )  to hdc  ;M
! 
! :M SelectObject:  ( object -- oldobj )
!         hDC Call SelectObject
!         ;M
  
  :M DeleteObject:  ( object -- )
!         Call DeleteObject ?win-error
!         ;M
! 
! :M GetStockObject: ( id -- object )
!         Call GetStockObject
!         ;M
! 
! :M SelectStockObject:  ( id -- oldobj )
!         GetStockObject: self  SelectObject: self
!         ;M
  
  :M GetTextMetrics:  ( tm -- )
!         hDC Call GetTextMetrics ?win-error
!         ;M
! 
! \ old Win32s support removed
! \ September 17th, 2003 - 10:38 dbu
! :M GetTextExtent:  { adr len \ exttemp -- width height }
!         2 cells LocalAlloc: exttemp     \ allocate some space
!         exttemp 2 cells erase           \ init it to zeros
!         exttemp
!         len
!         adr
!         hDC Call GetTextExtentPoint32 ?win-error
!         exttemp @                       \ the width
!         exttemp cell+ @                 \ the height
!         ;M
  
  :M SetTextColor:  { color_object -- }
          color_object ?ColorCheck drop
!         Color: color_object hdc Call SetTextColor drop
          ;M
  
  :M SetBkColor:  { color_object -- }
          color_object ?ColorCheck drop
!         Color: color_object hDC Call SetBkColor   drop
          ;M
  
  :M SetBkMode:   ( mode  -- )
!         hDC Call SetBkMode    drop
!         ;M
  
! :M SaveDC:      ( -- )  \ Save current DC context and objects including the
!                                                         \ current font.
!         hDC Call SaveDC drop
!         ;M
  
  :M RestoreDC:   ( -- )  \ restore current DC context including font
!         -1 hDC Call RestoreDC ?win-error
!         ;M
  
  :M SetFont:     ( font_handle -- )
--- 13,67 ----
  in-application
  
! needs gdi/gdiDC.f
  
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
! \ WinDC class
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
+ :CLASS WinDC   <Super gdiDC
  
! int hDC         \ Handle to the device context
!                 \ I can't get rid of it since some old applications
!                 \ are accesing this ivar like this: dc.hDC
  
  int currentfont
  
  Rectangle FillRect
  
  :M ClassInit:   ( -- )
          ClassInit: super
!         0 to currentfont
          ;M
  
! :M PutHandle:   ( hdc -- )
!         dup to hDC
!         to hObject  ;M
  
  :M DeleteObject:  ( object -- )
!         Call DeleteObject ?win-error ;M
  
  :M GetTextMetrics:  ( tm -- )
!         GetTextMetrics: super >r swap r> move ;M
  
  :M SetTextColor:  { color_object -- }
          color_object ?ColorCheck drop
!         Color: color_object SetTextColor: super drop
          ;M
  
  :M SetBkColor:  { color_object -- }
          color_object ?ColorCheck drop
!         Color: color_object SetBackgroundColor: super drop
          ;M
  
  :M SetBkMode:   ( mode  -- )
!         SetBackgroundMode: super drop ;M
  
! :M SaveDC:      ( -- )          \ Save current DC context and objects
!         Save: super drop ;M     \ including the current font.
  
  :M RestoreDC:   ( -- )  \ restore current DC context including font
!         Restore: super drop ;M
  
  :M SetFont:     ( font_handle -- )
***************
*** 133,235 ****
  
  :M GetFont:     ( -- font_handle )
!         currentfont
!         ;M
! 
! :M TextOut:     ( x y addr len -- )
!         4reverse hDC Call TextOut ?win-error
!         ;M
! 
! :M DrawText:    ( addr len rect format -- )
!         4reverse hDC Call DrawText drop
!         ;M
  
  :M TabbedTextOut: ( x y addr len -- text_dimensions )
!         2>r 2>r 0 tabbuf tabcnt 2r> 2r>
!         4reverse hDC Call TabbedTextOut
!         ;M
  
  :M LineColor:   { color_object -- }
          color_object ?ColorCheck drop
!         Pen: color_object hDC Call SelectObject drop
!         ;M
  
  :M PenColor:    ( color_object -- )
!         LineColor: self
!         ;M
  
  :M BrushColor:  { color_object -- }
          color_object ?ColorCheck drop
!         Brush: color_object hDC Call SelectObject drop
!         ;M
  
  :M MoveTo:      ( x y -- )
!         0 3reverse
!         hDC Call MoveToEx ?win-error
!         ;M
! 
! :M LineTo:      ( x y -- )
!         swap
!         hDC Call LineTo ?win-error
!         ;M
! 
! \ July 29th, 1998 - 9:03 tjz
! \ Removed an extra swap after 'rel>abs' in the following two definitions,
! \ per a bug reported by Pierre Abbat
! :M PolyBezierTo: ( ptr cnt -- )
!         swap hDC Call PolyBezierTo ?win-error ;M
! 
! :M PolyBezier:  ( ptr cnt -- )
!         swap hDC Call PolyBezier   ?win-error ;M
! 
! \ July 29th, 1998 - 9:03 tjz
! \ Added Polygon: as suggested by Pierre Abbat
! :M Polygon:     ( ptr cnt - )
!         swap hDC Call Polygon	?win-error ;m
! 
! \ Samstag, Oktober 01 2005 dbu
! \ Added as suggested by David R Pochin in Forthwrite 127 (December 2004)
! :M Polyline:	( ptr cnt - )
!         swap hDC Call Polyline  ?win-error ;m
  
  :M PolyDraw:    ( tptr pptr cnt -- )
!         rot hDC Call PolyDraw   ?win-error ;M
! 
! :M BeginPath:   ( -- )
!         hDC Call BeginPath      ?win-error ;M
! 
! :M FillPath:    ( -- )
!         hDC Call FillPath       ?win-error ;M
! 
! :M StrokePath:  ( -- )
!         hDC Call StrokePath     ?win-error ;M
! 
! \ Samstag, Oktober 01 2005 dbu
! \ Removed as suggested by David R Pochin in Forthwrite 127 (December 2004)
! \ :M FillPath:    ( -- )                  \ rls - new  ? Needs Brushes ?
! \         hDC Call FillPath       ?win-error ;M
! 
! :M StrokeAndFillPath:    ( -- )         \ rls - new  ? Needs Brushes ?
!         hDC Call StrokeAndFillPath      ?win-error ;M
! 
! :M EndPath:     ( -- )
!         hDC Call EndPath       	?win-error ;M
  
  :M SetROP2:     ( mode -- oldmode )
!         hDC Call SetROP2
!         ;M
  
  :M SetPixel:    { x y color_object -- }
!                 color_object ?ColorCheck drop
!                 Color: color_object y x hDC Call SetPixel drop
!                 ;M
  
  :M GetPixel:    ( x y -- colorref )   \ returns a "COLORREF", not a color object
!                 swap
!                 hDC Call GetPixel
!                 ;M
  
  :M BitBlt:      ( blitmode sourcex,y sourcedc sizex,y destinationx,y -- )
!                 2>r 2>r >r swap r> 2r> swap 2r> swap
!                 hdc ( 9 win-parameters ) call BitBlt ?win-error ;M
  
  :M StretchBlt:  ( blitmode srcsizex,y srcx,y srcdc dstsizex,y dstx,y -- )
--- 71,110 ----
  
  :M GetFont:     ( -- font_handle )
!         currentfont ;M
  
  :M TabbedTextOut: ( x y addr len -- text_dimensions )
!         TabbedTextOut: super word-join ;M
  
  :M LineColor:   { color_object -- }
          color_object ?ColorCheck drop
!         Pen: color_object SelectObject: super drop ;M
  
  :M PenColor:    ( color_object -- )
!         LineColor: self ;M
  
  :M BrushColor:  { color_object -- }
          color_object ?ColorCheck drop
!         Brush: color_object SelectObject: super drop ;M
  
  :M MoveTo:      ( x y -- )
!         MoveTo: super 2drop ;M
  
  :M PolyDraw:    ( tptr pptr cnt -- )
!         \ is ROT right?!? I think it should be 3REVERSE (dbu)
!         rot hObject Call PolyDraw ?win-error ;M
  
  :M SetROP2:     ( mode -- oldmode )
!         SetROP: super ;M
  
  :M SetPixel:    { x y color_object -- }
!         color_object ?ColorCheck drop
!         Color: color_object y x hObject Call SetPixel drop ;M
  
  :M GetPixel:    ( x y -- colorref )   \ returns a "COLORREF", not a color object
!         swap hObject Call GetPixel ;M
  
  :M BitBlt:      ( blitmode sourcex,y sourcedc sizex,y destinationx,y -- )
!         2>r 2>r >r swap r> 2r> swap 2r> swap
!         8reverse BitBlt: super ;M
  
  :M StretchBlt:  ( blitmode srcsizex,y srcx,y srcdc dstsizex,y dstx,y -- )
***************
*** 243,271 ****
          2r> swap                        \ recover, swap dstsizex,y
          2r> swap                        \ recover, swap dstx,y
!         hdc ( 11 win-parameters ) call StretchBlt ?win-error ;M
  
  :M FillRect:    { color_object rectangle -- }
          color_object ?ColorCheck drop
          Brush: color_object
!         rectangle hdc
!         ( 3 win-parameters ) Call FillRect ?win-error
          ;M
  
  :M FillArea:    { left top right bottom color_object -- }
          color_object ?ColorCheck drop
          Brush: color_object
!         left top right bottom SetRect: FillRect
!         Addrof: FillRect hdc
!         ( 3 win-parameters ) Call FillRect ?win-error
          ;M
  
- :M Ellipse:     { left top right bottom -- }
-         bottom right top left
-         hdc Call Ellipse ?win-error ;M
- 
- :M Arc:         { left top right bottom x1 y1 x2 y2 -- }
-         y2 x2 y1 x1 bottom right top left
-         hdc Call Arc ?win-error ;M
- 
  :M FillCircle:  { x y radius -- }
          x radius - y radius - x radius + y radius +
--- 118,137 ----
          2r> swap                        \ recover, swap dstsizex,y
          2r> swap                        \ recover, swap dstx,y
!         hObject ( 11 win-parameters ) call StretchBlt ?win-error ;M
  
  :M FillRect:    { color_object rectangle -- }
          color_object ?ColorCheck drop
+         Left: rectangle Top: rectangle Right: rectangle Bottom: rectangle
          Brush: color_object
!         FillRect: super
          ;M
  
  :M FillArea:    { left top right bottom color_object -- }
          color_object ?ColorCheck drop
+         left top right bottom
          Brush: color_object
!         FillRect: super
          ;M
  
  :M FillCircle:  { x y radius -- }
          x radius - y radius - x radius + y radius +
***************
*** 276,298 ****
          0 0 0 0 Arc: self ;M
  
! \ Samstag, Oktober 08 2005 dbu
! \ Added as suggested by Larry Daniel
! :M RoundRect: { left top right bottom width height -- }
!         height width bottom right top left hDC Call RoundRect ?win-error
!         ;M
! 
! \ Samstag, Oktober 08 2005 dbu
! \ Added as suggested by Larry Daniel
! :M InvertRect: ( left top right bottom  -- )
!         SetRect: FillRect
!         Addrof: FillRect hDC Call InvertRect ?win-error
!         ;M
! 
! :M CreateCompatibleBitmap: ( width height -- hbitmap )
!         swap hdc
!         Call CreateCompatibleBitmap ;M
  
! ;Class
  
  
    0 value #PAGES-UP
--- 142,155 ----
          0 0 0 0 Arc: self ;M
  
! ;class
  
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
! \ WinPrinter class
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  
+   8 value CHAR-WIDTH            \ Width of each character in pixels
+  14 value CHAR-HEIGHT           \ Height of each character in pixels
  
    0 value #PAGES-UP
***************
*** 458,462 ****
          NewColor: PRINTCOLOR
          penwidth PenWidth: PRINTCOLOR
!         Pen: PRINTCOLOR hDC Call SelectObject drop
          ;M
  
--- 315,319 ----
          NewColor: PRINTCOLOR
          penwidth PenWidth: PRINTCOLOR
!         Pen: PRINTCOLOR GetHandle: super Call SelectObject drop
          ;M
  
***************
*** 465,469 ****
                      Brush: PRINTFILLCOLOR
          left top right bottom SetRect: FillRect
!         FillRect.AddrOf hdc
          ( 3 win-parameters ) Call FillRect ?win-error
          ;M
--- 322,326 ----
                      Brush: PRINTFILLCOLOR
          left top right bottom SetRect: FillRect
!         FillRect.AddrOf GetHandle: super
          ( 3 win-parameters ) Call FillRect ?win-error
          ;M
***************
*** 472,485 ****
  
  :M Width:       ( -- horizontal-dots-on-page )
!         HORZRES hdc Call GetDeviceCaps
          ;M
  
  :M Height:      ( -- vertical-dots-on-page )
!         VERTRES hdc Call GetDeviceCaps
          ;M
  
  :M DPI:         ( -- horizontal-dots-per-inch  vertical-dots-per-inch )
!         LOGPIXELSX hdc Call GetDeviceCaps
!         LOGPIXELSY hdc Call GetDeviceCaps
          ;M
  
--- 329,346 ----
  
  :M Width:       ( -- horizontal-dots-on-page )
! \         HORZRES GetHandle: super Call GetDeviceCaps
!         HORZRES GetDeviceCaps: super
          ;M
  
  :M Height:      ( -- vertical-dots-on-page )
! \         VERTRES GetHandle: super Call GetDeviceCaps
!         VERTRES GetDeviceCaps: super
          ;M
  
  :M DPI:         ( -- horizontal-dots-per-inch  vertical-dots-per-inch )
! \         LOGPIXELSX GetHandle: super Call GetDeviceCaps
! \         LOGPIXELSY GetHandle: super Call GetDeviceCaps
!         LOGPIXELSX GetDeviceCaps: super
!         LOGPIXELSY GetDeviceCaps: super
          ;M
  
***************
*** 489,497 ****
  
  :M SetStretchBltMode:  ( mode_value -- )
!         hdc Call SetStretchBltMode drop
          ;M
  
  :M Nullify:     ( -- )                  \ mark the printer hdc as not in use
!         0 to hdc
          0 to drawlist
          0 to drawoff
--- 350,358 ----
  
  :M SetStretchBltMode:  ( mode_value -- )
!         GetHandle: super Call SetStretchBltMode drop
          ;M
  
  :M Nullify:     ( -- )                  \ mark the printer hdc as not in use
!         0 PutHandle: super
          0 to drawlist
          0 to drawoff
***************
*** 577,582 ****
                  IF      auto-print-init
                  ELSE         print-init
!                 THEN    dup to hdc
!         ELSE    hdc
          THEN
          -IF     set-print-params
--- 438,443 ----
                  IF      auto-print-init
                  ELSE         print-init
!                 THEN    dup PutHandle: super
!         ELSE    GetHandle: super
          THEN
          -IF     set-print-params
***************
*** 591,596 ****
                  IF      3drop auto-print-init
                  ELSE         print-init2
!                 THEN    dup to hdc
!         ELSE    3drop hdc
          THEN
          -IF     set-print-params
--- 452,457 ----
                  IF      3drop auto-print-init
                  ELSE         print-init2
!                 THEN    dup PutHandle: super
!         ELSE    3drop GetHandle: super
          THEN
          -IF     set-print-params
***************
*** 601,606 ****
  :M AutoOpen:    ( -- f1 )               \ open the printer for use
          printing? 0=
!         IF      auto-print-init dup to hdc
!         ELSE    hdc
          THEN
          -IF     set-print-params
--- 462,467 ----
  :M AutoOpen:    ( -- f1 )               \ open the printer for use
          printing? 0=
!         IF      auto-print-init dup PutHandle: super
!         ELSE    GetHandle: super
          THEN
          -IF     set-print-params
***************
*** 613,617 ****
  
  :M Landscape:   ( -- )
!         TRUE print-orientation dup to hdc
          IF      set-print-params
                  0 to #pages
--- 474,478 ----
  
  :M Landscape:   ( -- )
!         TRUE print-orientation dup PutHandle: super
          IF      set-print-params
                  0 to #pages
***************
*** 620,624 ****
  
  :M Portrait:    ( -- )
!         FALSE print-orientation dup to hdc
          IF      set-print-params
                  0 to #pages
--- 481,485 ----
  
  :M Portrait:    ( -- )
!         FALSE print-orientation dup PutHandle: super
          IF      set-print-params
                  0 to #pages
***************
*** 627,634 ****
  
  :M Start:       ( -- )                  \ start a new page and document
!         hdc 0=                  \ if not initialized
          penwidth -1 = or        \ or penwidth hasn't been set
          IF      Open: self      \ -- f1 = true if ready to print
!         ELSE    hdc
                  set-print-params
          THEN
--- 488,495 ----
  
  :M Start:       ( -- )                  \ start a new page and document
!         GetHandle: super 0=     \ if not initialized
          penwidth -1 = or        \ or penwidth hasn't been set
          IF      Open: self      \ -- f1 = true if ready to print
!         ELSE    GetHandle: super
                  set-print-params
          THEN
***************
*** 651,655 ****
  :M Setup:       ( window_handle -- )
          print-setup ?dup
!         IF      to hdc
                  set-rows-cols
          THEN    ;M
--- 512,516 ----
  :M Setup:       ( window_handle -- )
          print-setup ?dup
!         IF      PutHandle: super
                  set-rows-cols
          THEN    ;M
***************
*** 1049,1055 ****
          THEN
          false to drawing?
!         hdc
          IF      print-close
!                 0 to hdc
          THEN
          ;M
--- 910,916 ----
          THEN
          false to drawing?
!         GetHandle: super
          IF      print-close
!                 0 PutHandle: super
          THEN
          ;M

Index: FONTS.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/FONTS.F,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** FONTS.F	29 Aug 2005 15:56:27 -0000	1.5
--- FONTS.F	1 Nov 2005 12:21:40 -0000	1.6
***************
*** 4,127 ****
  \ Font creation Class and control methods
  
! in-application
! 
! VARIABLE font-link      \ Global linked list of font objects
!          font-link OFF
! 
! :Class Font     <Super Object
! 
! int handle              \ the handle to the created font
! 
! Record: LOGFONT         \ structure that holds
!                 int   lfHeight          \ width  in pixels, device specific
!                 int   lfWidth           \ height in pixels, device specific
!                 int   lfEscapement
!                 int   lfOrientation     \ in 10ths of a degree
!                 int   lfWeight
!                 byte  lfItalic          \ TRUE/FALSE
!                 byte  lfUnderline       \ TRUE/FALSE
!                 byte  lfStrikeOut       \ TRUE/FALSE
!                 byte  lfCharSet
!                 byte  lfOutPrecision
!                 byte  lfClipPrecision
!                 byte  lfQuality
!                 byte  lfPitchAndFamily
!     LF_FACESIZE bytes lfFaceName        \ the font name
! ;Record
! 
! : trim-fonts  ( nfa -- nfa )
! \in-system-ok   dup font-link full-trim ;
! 
! \in-system-ok forget-chain chain-add trim-fonts
  
! :M ClassInit:   ( -- )
!                  0                  to handle           \ clear handle
!                 14                  to lfHeight
!                  9                  to lfWidth
!                  0                  to lfEscapement
!                  0                  to lfOrientation    \ in 10th degrees
!                 FW_DONTCARE         to lfWeight
!                 FALSE               to lfItalic
!                 FALSE               to lfUnderline
!                 FALSE               to lfStrikeOut
!                 ANSI_CHARSET        to lfCharSet
!                 OUT_TT_PRECIS       to lfOutPrecision
!                 CLIP_DEFAULT_PRECIS to lfClipPrecision
!                 PROOF_QUALITY       to lfQuality
!                 FIXED_PITCH                             \ font pitch
!                 0x04 or                                 \ use TrueType fonts
!                 FF_SWISS or         to lfPitchAndFamily \ font family
!                 lfFaceName LF_FACESIZE erase            \ clear font name
!                 s" Courier New" lfFaceName swap move    \ move in default name
!                 font-link link,                         \ link into list
!                 self ,                                  \ so we can send
!                 ;M                                      \ ourself messages
  
! :M Height:         ( n1 -- )  to lfHeight          ;M
! :M Width:          ( n1 -- )  to lfWidth           ;M
! :M Escapement:     ( n1 -- )  to lfEscapement      ;M
! :M Orientation:    ( n1 -- )  to lfOrientation     ;M   \ 10th/degree increments
! :M Weight:         ( n1 -- )  to lfWeight          ;M
! :M Italic:         ( f1 -- )  to lfItalic          ;M   \ TRUE/FALSE
! :M Underline:      ( f1 -- )  to lfUnderline       ;M   \ TRUE/FALSE
! :M StrikeOut:      ( f1 -- )  to lfStrikeOut       ;M   \ TRUE/FALSE
! :M CharSet:        ( n1 -- )  to lfCharSet         ;M
! :M OutPrecision:   ( n1 -- )  to lfOutPrecision    ;M
! :M ClipPrecision:  ( n1 -- )  to lfClipPrecision   ;M
! :M Quality:        ( n1 -- )  to lfQuality         ;M
! :M PitchAndFamily: ( n1 -- )  to lfPitchAndFamily  ;M
  
! :M SetFaceName: ( a1 n1 -- )
!                 lfFaceName LF_FACESIZE erase
!                 LF_FACESIZE 1- min lfFaceName swap move
!                 ;M
  
! :M GetFaceName: ( -- a1 n1 )
!                 lfFaceName LF_FACESIZE 2dup 0 scan nip -
!                 ;M
  
  :M Delete:      ( -- )
!                 handle ?dup
!                 if      Call DeleteObject ?win-error
!                         0 to handle
!                 then
!                 ;M
! 
! :M Create:      ( -- )
!                 Delete: self
!                 LOGFONT Call CreateFontIndirect to handle
!                 ;M
! 
! :M Handle:      ( -- HFONT )
!                 handle
!                 ;M
! 
! \ **************** INTERNAL SYSTEM FUNCTIONS FOLLOW ****************
! \ The following functions and methods make sure that any font objects
! \ created in your application get reset at system startup, and deleted
! \ when Win32Forth closes.
! 
! :M zHandle:     ( -- )          \ zero the font handle
!                 0 to handle
!                 ;M
! 
! : do-fonts    { method -- }
!                 font-link @             \ clear all font handles
!                 begin   dup
!                 while   dup cell+ @
!                         method execute
!                         @
!                 repeat  drop ;
! 
! : zero-fonts    ( -- )
!                 [getmethod] zHandle: font do-fonts ;
! 
! initialization-chain chain-add zero-fonts
! 
! : delete-fonts  ( -- )
!                 [getmethod] Delete: font do-fonts ;
! 
! unload-chain chain-add delete-fonts
  
! ;Class
  
--- 4,37 ----
  \ Font creation Class and control methods
  
! cr .( Loading Font class...)
  
! in-application
  
! needs gdi/gdiFont.f
  
! \ ----------------------------------------------------------------------
! \ Font class
! \ ----------------------------------------------------------------------
! :Class Font     <Super GdiFont
  
! :M Height:         ( n1 -- )  SetHeight: super         ;M
! :M Width:          ( n1 -- )  SetWidth: super          ;M
! :M Escapement:     ( n1 -- )  SetEscapement: super     ;M
! :M Orientation:    ( n1 -- )  SetOrientation: super    ;M
! :M Weight:         ( n1 -- )  SetWeight: super         ;M
! :M Italic:         ( f1 -- )  SetItalic: super         ;M
! :M Underline:      ( f1 -- )  SetUnderline: super      ;M
! :M StrikeOut:      ( f1 -- )  SetStrikeOut: super      ;M
! :M CharSet:        ( n1 -- )  SetCharSet: super        ;M
! :M OutPrecision:   ( n1 -- )  SetOutPrecision: super   ;M
! :M ClipPrecision:  ( n1 -- )  SetClipPrecision: super  ;M
! :M Quality:        ( n1 -- )  SetQuality: super        ;M
! :M PitchAndFamily: ( n1 -- )  SetPitchAndFamily: super ;M
  
  :M Delete:      ( -- )
!                 Destroy: super ;M
  
! :M Handle:      ( -- hFont )
!                 GetHandle: super ;M
  
+ ;class

Index: paths.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/paths.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** paths.f	29 Aug 2005 15:56:28 -0000	1.5
--- paths.f	1 Nov 2005 12:21:40 -0000	1.6
***************
*** 133,136 ****
--- 133,137 ----
                  s" src"     "fpath+
                  s" src\lib" "fpath+
+                 s" src\gdi" "fpath+ \ GDI class library
                  s" src\res" "fpath+
                  s" src\console" "fpath+

[Win32forth-cvs] win32forth/demos/GdiDemo BitBlt.f,NONE,1.1 Figfonts.f,NONE,1.1 Figraph.f,NONE,1.1 Metafile.emf,NONE,1.1 Metafile.f,NONE,1.1 SixEasyFonts.f,NONE,1.1 TextList.f,NONE,1.1 TxtAlign.f,NONE,1.1

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/demos/GdiDemo
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13139/demos/GdiDemo

Added Files:
	BitBlt.f Figfonts.f Figraph.f Metafile.emf Metafile.f 
	SixEasyFonts.f TextList.f TxtAlign.f 
Log Message:
- Added my GDI class library to the CVS
- WinDC and Font classes rewritten to use the GDI class library
- Added some demo's whitch are using the GDI class library

--- NEW FILE: Metafile.f ---
\ File:         GdiDemo.f
\ Purpose:      Demo application fpr the GDI class library
\ Written:      Sonntag, Oktober 30 2005 by Dirk Busch
\ Licence:      Public Domain

cr .( Loading GDI class library demo - Main...)

anew -gdidemo.f

needs gdi/gdi.f \ the GDI class library

0 value create-tunkey?

\ ----------------------------------------------------------------------
\ the Main window
\ ----------------------------------------------------------------------
:object GdiDemoWindow <super WINDOW

gdiPen          tPen
gdiSolidBrush   tSolidBrush
gdiHatchBrush   tHatchBrush
gdiFont         tFont
gdiWindowDC     tDC
gdiMetafileDC   tMetaDC

\ Create a metafile and store it on disk.
\ This metafile will be displayed during repaint
create FileName ," Metafile.emf"
create Text1    ," This is a Text"
create Text2    ,"TEXT" "This is a Text with a\TTAB"

: CreateIt      ( -- )
        hWnd GetDC: tDC
        if
                \ Start recording a metafile for this window
                0 0 Width Height tDC CalcMetaRect: tMetaDC
                tDC StartRecording: tMetaDC
                if
                        \ setup the MetafileDC
                        MM_TEXT SetMapMode: tMetaDC
                        0 0 SetWindowOrg: tMetaDC

                        \ draw something into the metafile
                        tPen SelectObject: tMetaDC
                        tHatchBrush SelectObject: tMetaDC

                         50  50 100 125 Rectangle: tMetaDC
                        125 125 150 175 Ellipse: tMetaDC

                        AD_COUNTERCLOCKWISE SetArcDirection: tMetaDC
                        190 60 120 140 200 240 120 70 Pie: tMetaDC
                        290 160 120 140 200 240 120 70 Chord: tMetaDC
                        SetArcDirection: tMetaDC drop

                        SelectObject: tMetaDC drop \ tHatchBrush

                        tSolidBrush SelectObject: tMetaDC

                        AD_CLOCKWISE SetArcDirection: tMetaDC
                        190 60 120 140 200 240 120 70 Pie: tMetaDC
                        290 160 120 140 200 240 120 70 Chord: tMetaDC
                        SetArcDirection: tMetaDC drop

                        SelectObject: tMetaDC drop \ tSolidBrush
                        SelectObject: tDC drop \ tPen

                         20 300 120 350 tHatchBrush FillRect: tMetaDC
                        120 300 220 350 tHatchBrush FrameRect: tMetaDC

                        tFont SelectObject: tMetaDC
                        20 350 Text1 count TextOut: tMetaDC

                        20 SetTabSize: tMetaDC
                        20 400 Text2 count TabbedTextOut: tMetaDC 2drop
                        SetTabSize: tMetaDC drop \ TabSize

                        SelectObject: tMetaDC drop \ tFont

                        \ cleanup the MetafileDC
                        SetMapMode: tMetaDC drop
                        SetWindowOrg: tMetaDC 2drop

                        \ stop recording
                        StopRecording: tMetaDC
                        if   \ save it
                             FileName count Save: tMetaDC drop
                        then
                        Destroy: tMetaDC
                then
                Release: tDC
        then ;

\ Load the Metafile and draw it
: LoadAndDrawIt ( -- )
        FileName count Load: tMetaDC \ load the metafile from disk
        if   0 0 Width Height tDC Draw: tMetaDC \ and draw it in our window
             Destroy: tMetaDC \ clean up
        then ;

:M On_Paint:    ( -- )
        GetHandle: self GetDC: tDC
        if   LoadAndDrawIt
             Release: tDC
        then ;M

:M Start:       ( -- )

        \ create a Pen
        hWnd ChooseColor: tPen 0=
        if 255 SetRValue: tPen then
        PS_DASHDOTDOT SetStyle: tPen
        Create: tPen drop

        \ create a solid brush
        hWnd ChooseColor: tSolidBrush 0=
        if 255 SetGValue: tSolidBrush then
        Create: tSolidBrush drop

        \ create a hatch brush
        hWnd ChooseColor: tHatchBrush 0=
        if 255 SetBValue: tHatchBrush then
        HS_DIAGCROSS SetStyle: tHatchBrush
        Create: tHatchBrush drop

        \ let the user choose a font
        hWnd Choose: tFont 0=
        if      \ create a font
                s" Times New Roman" SetFaceName: tFont
                true SetUnderline: tFont
                true SetItalic: tFont
                20 SetHeight: tFont
                Create: tFont drop
        then


        Start: super    \ display our window
        CreateIt        \ create our metafile
        Paint: super    \ and force a repaint
        ;M

:M On_Done:     ( -- )
        TURNKEYED? 0=
        if      Destroy: tPen
                Destroy: tSolidBrush
                Destroy: tHatchBrush
                Destroy: tDC
                Destroy: tMetaDC
        then
        On_Done: super ;M


;object

\ ----------------------------------------------------------------------
\ Start the demo or create a turnkey application
\ ----------------------------------------------------------------------

: GdiDemo ( -- )
        Start: GdiDemoWindow ;

create-tunkey? [if]
        ' GdiDemo turnkey GdiDemo.exe
[else]
        GdiDemo
[then]

--- NEW FILE: SixEasyFonts.f ---
\ SixEasyFonts.F
\ Written by David R. Pochin
\ Changed to use the GDI class library by Dirk Busch

\ Using Windows Stock Fonts

ANEW -SixEasyFonts.F

needs gdi/gdi.f

\ Define an Object that is a child object of the Class "Window".
:OBJECT Fontdemo <SUPER WINDOW

gdiWindowDC tDC

:M WindowTitle: ( -- title )         \ Title for the window.
                z" Six Easy Fonts      One example only"
                ;M

:M StartSize:   ( -- width height )  \ Set width and height of window
                500 200
                ;M

:M StartPos:    ( -- x y )           \ Set the screen origin.
                100 100
                ;M

:M Close:       ( -- )               \ Do anything the class needs.
                Destroy: tDC
                Close: SUPER
                ;M

:M On_Paint:  ( -- )                 \ screen redraw procedure

        GetHandle: self GetDC: tDC
        if
             DEVICE_DEFAULT_FONT SelectStockObject: tDC
             20 30 s" DEVICE_DEFAULT_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC

             SYSTEM_FONT SelectStockObject: tDC drop
             20 50 s" SYSTEM_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC

             SYSTEM_FIXED_FONT SelectStockObject: tDC drop
             20 70 s" SYSTEM_FIXED_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC

             OEM_FIXED_FONT SelectStockObject: tDC drop
             20 90 s" OEM_FIXED_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC

             ANSI_FIXED_FONT SelectStockObject: tDC drop
             20 110 s" ANSI_FIXED_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC

             ANSI_VAR_FONT SelectStockObject: tDC drop
             20 130 s" ANSI_VAR_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC

             SelectObject: tDC drop \ clean up
             Release: tDC
        then ;M

;OBJECT \ Complete the definition of the new object.

: FONTS ( -- )
        Start: Fontdemo ;

FONTS

\ END OF LISTING.



--- NEW FILE: Figraph.f ---
\ FIGRAPH.F    Example of Object Oriented Graphics
\ Written by David R. Pochin
\ Changed to use the GDI class library by Dirk Busch

\ Examples of pens, brushes, lines, shapes and fills.

anew -FigGraph.f

needs gdi/gdi.f

\ Define an Object that is a child of the Class Window
:OBJECT Grafdemo <SUPER WINDOW

ButtonControl Button_1   \ a button

gdiWindowDC tDC

\ Set Up handles for Pens and Brushes.
gdiPen hPen1
gdiPen hPen2
gdiPen hPen3
gdiPen hPen4
gdiHatchBrush hBrush1

\ Set up Array of Data Points for use with Polyline.
Create POLYDATA
        ( x1 , y1 , x2 , y2 , etc )
        140 , 70 , 180 , 100 , 200 , 50 , 230 , 90 , 250 , 80 ,

\ Things to do at the start of window creation
:M ClassInit:   ( -- )
        ClassInit: super \ Do anything the super class needs.
        ;M

:M WindowTitle: ( -- title )
        z" Drawing Figures with Win32Forth " ;M

:M StartSize:   ( -- width height )
        550 230 ;M

:M StartPos:    ( -- x y )
        100 100 ;M

\ Create five drawing methods.
\ Follow these patterns for other Windows figures such as Arc.
:M DrawRect:    ( bottom right top left -- )
        4reverse Rectangle: tDC ;M

:M DrawEllipse: ( bottom right top left -- )
        4reverse Ellipse: tDC ;M

:M DrawPie: ( Drawn counter clockwise from xstart, ystart )
        ( yfinish xfinish ystart xstart bottom right top left  -- )
        8reverse Pie: tDC ;M

:M DrawRoundRect: ( ycnr xcnr bottom right top left -- )
        6reverse RoundRect: tDC ;M

:M DrawPolyLine:  ( n addr -- )
        swap Polyline: tDC ;M

\ Remember to delete any objects you have made before closing.
:M Close:       ( -- )
        Destroy: hPen1
        Destroy: hPen2
        Destroy: hPen3
        Destroy: hPen4
        Destroy: hBrush1
        Destroy: tDC
        Close: super
        ;M

:M On_Init:     ( -- )

        \ Set up a Button
        IDOK               SetID: Button_1
        self               Start: Button_1
        160 180 70 25       Move: Button_1
        s" CLOSE"        SetText: Button_1
                        GetStyle: Button_1 BS_DEFPUSHBUTTON OR
                        SetStyle: Button_1

        \ Create all non Stock Object Pens and Brushes required.
        \ ONLY PenWidth 1 allowed with PenStyles other than PS_SOLID
        128 128 128 SetRGB: hPen1 12 SetWidth: hPen1 PS_SOLID SetStyle: hPen1 Create: hPen1
          0   0 255 SetRGB: hPen2  1 SetWidth: hPen1 PS_DOT   SetStyle: hPen2 Create: hPen2
        255   0   0 SetRGB: hPen3  4 SetWidth: hPen1 PS_SOLID SetStyle: hPen3 Create: hPen3
          0  255  0 SetRGB: hPen4  1 SetWidth: hPen1 PS_NULL  SetStyle: hPen4 Create: hPen4

          0 128 128 SetRGB: hBrush1 HS_DIAGCROSS SetStyle: hBrush1 Create: hBrush1

        ;M

:M On_Paint:  ( -- )          \ screen redraw procedure
        GetHandle: self GetDC: tDC
        if
                \ Select pen hPen1
                hPen1 SelectObject: tDC

                \ Set Brush to LTGREEN
                Brush: LTGREEN SelectObject: tDC

                \ draw a rectangle with solid fill
                hPen1 SelectObject: tDC
                100 80 20 20 DrawRect: self

                \ change pen to hPen2 and
                \ draw a dotted line
                hPen2 SelectObject: tDC drop
                100 20 MoveTo: tDC
                230 20 LineTo: tDC

                \ Select pen hPen3 and draw an ellipse
                Brush: LTYELLOW SelectObject: tDC drop
                hPen3 SelectObject: tDC drop
                100 485 40 340 DrawEllipse: self

                \ Select pen hPen3 and draw a pie
                Brush: LTCYAN SelectObject: tDC drop
                hPen4 SelectObject: tDC drop
                190 60 120 140 200 240 120 70 DrawPie: self

                \ Select pen hPen2, change background color,
                \ brush and draw a rounded rectangle
                Color: LTRED SetBackgroundColor: tDC
                hBrush1 SelectObject: tDC drop
                hPen2 SelectObject: tDC drop
                20 80 200 515 120 290 DrawRoundRect: self

                \ Change the pen colour and brush, draw an ellipse
                Color: WHITE SetBackgroundColor: tDC
                Pen: LTGREEN SelectObject: tDC drop
                NULL_BRUSH SelectStockObject: tDC drop \ this doesn't work... why?
                150 520 20 280 DrawEllipse: self

                \ Change the pen colour and draw a polyline
                Pen: MAGENTA SelectObject: tDC drop
                5 POLYDATA DrawPolyLine: self

                \ cleanup
                SelectObject: tDC drop \ bursh
                SelectObject: tDC drop \ pen
                Release: tDC
        then ;M

 :M WM_COMMAND   ( hwnd msg wparam lparam -- res )
        OVER LOWORD ( Id )
        CASE    IDOK OF Close: self ENDOF
        ENDCASE 0 ;M

 ;OBJECT

: DEMO  ( -- )
        Start: Grafdemo ;
DEMO

\ END OF LISTING


--- NEW FILE: Metafile.emf ---
(This appears to be a binary file; contents omitted.)

--- NEW FILE: Figfonts.f ---
\ FigFonts.F   Listing for 'Win32Forth Fonts'.
\ Written by David R. Pochin
\ Changed to use the GDI class library by Dirk Busch

\ Examples of Fonts

anew -FigFonts.f

needs gdi/gdi.f

\ Define an Object that is a child object of the Class "Window".
:OBJECT Fontdemo <SUPER WINDOW

ButtonControl Button_1   \ Declare a button

gdiWindowDC tDC
gdiFont     aFont    \ Create a object of the class font
gdiFont     bFont    \ and another

:M ClassInit:   ( -- )          \ Things to do at the start of window creation.
        ClassInit: SUPER    \ Do anything the class needs.

                                 \ set the default font type for printing
        s" Impact"      SetFaceName: aFont
        24              SetHeight: aFont
        true            SetUnderline: aFont
        VARIABLE_PITCH 0x04 or FF_SWISS or
                        SetPitchAndFamily: aFont

        s" CommonBullets" SetFaceName: bFont
        2                 SetCharSet: bfont
        30                SetHeight: bFont
        14                SetWidth: bFont
        FW_NORMAL         SetWeight: bFont
        VARIABLE_PITCH 0x04 or FF_MODERN or FF_DECORATIVE or
                          SetPitchAndFamily: bFont
        ;M

:M WindowTitle: ( -- title )         \ Title for the window.
        z" Non Stock Fonts " ;M

:M StartSize:   ( -- width height )  \ Set width and height of window
        600 180 ;M

:M StartPos:    ( -- x y )           \ Set the screen origin.
        80 100  ;M

:M Close:       ( -- )               \ Do anything the class needs.
        Destroy: tDC    \ delete the dc
        Destroy: aFont  \ delete the fonts no longer needed
        Destroy: bFont
        Close: super
        ;M

:M On_Init:     ( -- )

        \ Add a button.
        IDOK             SetID: Button_1
        self             Start: Button_1
        480 140 70 25     Move: Button_1
        s" CLOSE"      SetText: Button_1
                      GetStyle: Button_1 BS_DEFPUSHBUTTON OR
                      SetStyle: Button_1

        \ create the fonts
        Create: aFont
        Create: bFont
        ;M

:M On_Paint:  ( -- )          \ screen redraw procedure
        GetHandle: self GetDC: tDC
        if
             \ Output the first text string.
             \ Example of the Forth word s" and see the method TextOut: in dc.f
             \ Note TextOut: requires the length of the string.

             aFont SelectObject: tDC
             20 30 s" aFont AaBbCcDdEeFfGgHhIiJjKkLl"  TextOut: tDC

             bFont SelectObject: tDC drop
             20 80 s" bFont AaBbCcDdEeFfGgHhIiJjKkLl"  TextOut: tDC

             \ cleanup
             SelectObject: tDC drop
             Release: tDC
        then ;M

:M WM_COMMAND   ( hwnd msg wparam lparam -- res )
        over LOWORD    \ fetch the identity of the Ok button which is in wParam
        case           \ case .. of .. endof .. endcase is a Forth defined
                       \ switch construction
             IDOK of   \ IDOK is the identity of Button_1
                    Close: self
                  endof
        endcase
        0 ;M

;OBJECT         \ Complete the definition of the new object.

: DEMO          ( -- )
                Start: Fontdemo ;
demo

\ END OF LISTING.



--- NEW FILE: BitBlt.f ---
\ BitBlt.F    Examples of Raster Operations
\ Written by David R. Pochin
\ Changed to use the GDI class library by Dirk Busch

\ Examples of FillRect and BitBlt.

anew -BitBlt.f

needs gdi/gdi.f

\ Define an Object that is a child of the Class Window
:OBJECT Bltdemo <SUPER WINDOW

gdiWindowDC   tDC
gdiSolidBrush tBrushRED
gdiSolidBrush tBrushGREEN
gdiSolidBrush tBrushBLACK

ButtonControl Button_1   \ a button

:M WindowTitle: ( -- title )
        z" BitBlt V.1.1 " ;M

:M StartSize:   ( -- width height )
        550 350 ;M

:M StartPos:    ( -- x y )
        100 100 ;M

:M Close:       ( -- )
        Destroy: tDC
        Destroy: tBrushRED
        Destroy: tBrushGREEN
        Destroy: tBrushGREEN
        Close: super
        ;M

\ Set up a Button and create Pens and Brushes.
:M On_Init:     ( -- )

        \ init the brushes
        255 SetRValue: tBrushRED
          0 SetGValue: tBrushRED
          0 SetBValue: tBrushRED
        Create: tBrushRED

          0 SetRValue: tBrushGREEN
        255 SetGValue: tBrushGREEN
          0 SetBValue: tBrushGREEN
        Create: tBrushGREEN

\       0 SetRValue: tBrushBLACK \ Note that Black is the default
\       0 SetGValue: tBrushBLACK \ color, so we don't need to
\       0 SetBValue: tBrushBLACK \ set the color.
        Create: tBrushBLACK

        \ create a pushbutton to close the demo
        IDOK               SetID:   Button_1
        self               Start:   Button_1
        420 300 70 25      Move:    Button_1
        s" CLOSE"          SetText: Button_1
                          GetStyle: Button_1 BS_DEFPUSHBUTTON OR
                          SetStyle: Button_1
        ;M

\ Note: This demo was originaly written using the 'old' DC class.
\ The BitBlt: method of the gdiDC class is unsig a different stack
\ layout. So this method was added fpr compatiblity.
:M BitBlt:      ( blitmode sourcex,y sourcedc sizex,y destinationx,y -- )
        2>r 2>r >r swap r> 2r> swap 2r> swap
        8reverse ( nXDest nYDest nWidth nHeight hdcSrc nXSrc nYSrc dwRop -- )
        BitBlt: tDC ;M

:M SetUps: { left top right bottom -- }
        \ draw frames for blocks
         39  39 MoveTo: tDC 120 39 LineTo: tDC 120 120 LineTo: tDC
         39 120 LineTo: tDC  39 39 LineTo: tDC

        159  39 MoveTo: tDC 240 39 LineTo: tDC 240 120 LineTo: tDC
        159 120 LineTo: tDC 159 39 LineTo: tDC

        359  39 MoveTo: tDC 440 39 LineTo: tDC 440 120 LineTo: tDC
        359 120 LineTo: tDC 359 39 LineTo: tDC

         39 179 MoveTo: tDC 120 179 LineTo: tDC 120 260 LineTo: tDC
         39 260 LineTo: tDC  39 179 LineTo: tDC

        159 179 MoveTo: tDC 240 179 LineTo: tDC 240 260 LineTo: tDC
        159 260 LineTo: tDC 159 179 LineTo: tDC

        359 179 MoveTo: tDC 440 179 LineTo: tDC 440 260 LineTo: tDC
        359 260 LineTo: tDC 359 179 LineTo: tDC

        \ Make the source, original destination and destination blocks

        80 40 120  80 tBrushGREEN FillRect: tDC
        40 80  80 120 tBrushBLACK FillRect: tDC
        NOTSRCCOPY 40 40 GetHandle: tDC 80 80 160 40 BitBlt: self
        SRCCOPY   160 40 GetHandle: tDC 80 80 360 40 BitBlt: self

         40 220 120 260 tBrushBLACK FillRect: tDC
        200 180 240 260 tBrushBLACK FillRect: tDC
        SRCCOPY 160 180 GetHandle: tDC 80 80 360 180 BitBlt: self

        \ Setup the text
         55  16 s" Source" TextOut: tDC
        160  16 s" Destination" TextOut: tDC
        280  16 s" Blt" TextOut: tDC
        375  16 s" Result" TextOut: tDC
        260  50 s" PATPAINT" TextOut: tDC
        255 210 s" MERGECOPY" TextOut: tDC
        ;M

:M BitBlts:
        \ Top row of display. Alternatively use any of
        \  BLACKNESS WHITENESS NOTSRCCOPY SRCCOPY
        \  PATCOPY PATINVERT DSINVERT
        PATPAINT 40 40 GetHandle: tDC 80 80 360 40 BitBlt: self

        \ Bottom row of display. Aternatively use any of
        \ SRCERASE SRCINVERT SRCPAINT MERGEPAINT NOTSRCERASE
        \ SRCAND
        MERGECOPY 40 180 GetHandle: tDC 80 80 360 180 BitBlt: self
        ;M

:M On_Paint:  ( -- )          \ screen redraw procedure
        GetHandle: self GetDC: tDC
        if   tBrushRED SelectObject: tDC \ Use this brush as the current pattern

             SetUps: self
             BitBlts: self

             \ cleanup
             SelectObject: tDC drop
             Release: tDC
        then ;M

:M WM_COMMAND   ( hwnd msg wparam lparam -- res )
        OVER LOWORD ( Id )
        CASE    IDOK OF Close: self ENDOF
        ENDCASE
        0 ;M

;OBJECT

: DEMO  ( -- )
        Start: Bltdemo ;
DEMO

\ END OF LISTING


--- NEW FILE: TxtAlign.f ---
\ TextAlign.F
\ Written by David R. Pochin
\ Changed to use the GDI class library by Dirk Busch

anew -TextAlign

needs gdi/gdi.f

:Object TextAlign  <Super Window

gdiFont     tFont
gdiWindowDC tDC

ButtonControl Button_1   \ a button

:M WindowTitle: ( -- title )
        z" Text Alignment" ;M

:M StartSize:   ( -- w h )      \ the width and height of our window
        230 200 ;M

:M StartPos:    ( -- x y )      \ the screen origin of our window
        100 100 ;M

:M SetLines:    ( -- )
         80  10 MoveTo: tDC
         80 110 LineTo: tDC
         10 140 MoveTo: tDC
        210 140 LineTo: tDC
        ;M

:M PrintText:   ( -- )

        \ select out Font into the DC
        tFont SelectObject: tDC

        \ draw some Text
        TA_LEFT SetTextAlign: tDC
        80 20 s" LEFT" TextOut: tDC

        TA_CENTER SetTextAlign: tDC drop
        80 50 s" CENTRE" TextOut: tDC

        TA_RIGHT SetTextAlign: tDC drop
        80 80  s" RIGHT" TextOut: tDC

        TA_TOP SetTextAlign: tDC drop
        30 140  s" TOP" TextOut: tDC

        TA_BOTTOM SetTextAlign: tDC drop
        70 140  s" BOTTOM" TextOut: tDC

        TA_BASELINE SetTextAlign: tDC drop
        155 140  s" BASE" TextOut: tDC

        SetTextAlign: tDC drop \ reset Text alignment
        SelectObject: tDC drop \ reset Font
        ;M

:M On_Paint:    ( -- )
        GetHandle: self GetDC: tDC
        if   SetLines: self
             PrintText: self
             Release: tDC
        then ;M

:M On_Init:     ( -- )  \ things to do at the start of window creation
        On_Init: super  \ do anything superclass needs

        \ init the pushbutton to close the application
        IDOK               SetID: Button_1
        self               Start: Button_1
        80 160 60 25        Move: Button_1
        s" CLOSE"        SetText: Button_1
        BS_DEFPUSHBUTTON  +Style: Button_1

        \ create a font
        s" Arial" SetFaceName: tFont
        10 SetHeight: tFont
        Create: tFont drop
        ;M

:M WM_COMMAND   ( hwnd msg wparam lparam -- res )
        OVER LOWORD ( Id )
        CASE    IDOK OF Close: self ENDOF
        ENDCASE
        0 ;M

:M Close:       ( -- )  \ Do anything the class needs.
        Destroy: tFont
        Destroy: tDC

        Close: SUPER
        ;M

;Object

: DEMO  ( -- )  \ start running the demo program
        Start: TextAlign ;

\ Runs on load.
demo

\ End of Listing.


--- NEW FILE: TextList.f ---
\ TextList.F    Example of Object Oriented Text Strings
\ Written by David R. Pochin
\ Changed to use the GDI class library by Dirk Busch

\ Examples of text foreground, background and mode options.

anew -TextList.f

needs gdi/gdi.f

\ Define an Object that is a super object of the Class "Window".
:OBJECT Stringdemo <SUPER WINDOW

gdiWindowDC   tDC
ButtonControl Button_1   \ Declare a button

:M WindowTitle: ( -- title )         \ Title for the window.
        z" Text String Objects. Win32Forth " ;M

:M StartSize:   ( -- width height )  \ Set width and height of window
        500 270 ;M

:M StartPos:    ( -- x y )           \ Set the screen origin.
        200 100  ;M

:M DrawRect:    ( y2 x2 y1 x1 -- )   \ See method GetHandle: in dc.f
        4reverse Rectangle: tDC ;M

:M Close:       ( -- )               \ Do anything the class needs.
        Destroy: tDC
        Close: super
        ;M

:M On_Init:     ( -- )
        \ Add a button.
        IDOK               SetID: Button_1
        self               Start: Button_1
        190 220 70 25       Move: Button_1
        s" CLOSE"        SetText: Button_1
                        GetStyle: Button_1 BS_DEFPUSHBUTTON OR
                        SetStyle: Button_1
        ;M

:M On_Paint:  ( -- )          \ screen redraw procedure
        GetHandle: self GetDC: tDC
        if
                \ Output the first text string.
                \ Example of the Forth word s" and see the method TextOut: in dc.f
                \ Note TextOut: requires the length of the string.
                90 20 s" COUNTED STRING. DEFAULT SETTINGS"  TextOut: tDC

                \ Set TextColor and BkColor.
                \ See the methods in dc.f which call Windows functions.
                Color: LTBLUE SetTextColor: tDC
                Color: LTRED SetBackgroundColor: tDC

                \ Set up two rectangles to see Mode Effects.
                \ Again see the methods in dc.f
                Brush: LTYELLOW SelectObject: tDC
                205 220 50 100 DrawRect: self
                Brush: LTGREEN SelectObject: tDC drop
                205 340 50 220 DrawRect: self

                \ Output the second text string.
                \ Used the z" word this time, note the string count required '53'
                \ As expected TextOut: is a method in dc.f
                20 60 z" LTBLUE Foreground and LTRED Background. BkMode OPAQUE" 53 TextOut: tDC

                \ Change background mode.
                TRANSPARENT SetBackgroundMode: tDC
                15 90 s" LTBLUE Foreground and LTRED Background. BkMode TRANSPARENT" TextOut: tDC

                \ Change Text Color to White
                Color: LTGREEN SetTextColor: tDC drop
                10 120 s" LTRED Background and LTGREEN Foreground. BkMode TRANSPARENT" TextOut: tDC

                \ Reset background mode to Opaque.
                OPAQUE SetBackgroundMode: tDC drop
                10 150 s" LTRED Background and LTGREEN Foreground. BkMode OPAQUE" TextOut: tDC

                \ Back to Defaults.
                SetBackgroundMode: tDC drop
                SelectObject: tDC drop \ bursh
                SetBackgroundColor: tDC drop
                SetTextColor: tDC drop
                120 180 s" Back to DEFAULT conditions." TextOut: tDC

                \ clean up
                Release: tDC
        then
        ;M

:M WM_COMMAND   ( hwnd msg wparam lparam -- res )
        over LOWORD    \ fetch the identity of the Ok button which is in wParam
        case           \ case .. of .. endof .. endcase is a Forth defined
                       \ switch construction
             IDOK of   \ IDOK is the identity of Button_1
                    Close: self
                  endof
        endcase
        0 ;M

;OBJECT         \ Complete the definition of the new object.

: DEMO          ( -- )
        Start: Stringdemo ;
demo

\ END OF LISTING.

[Win32forth-cvs] win32forth/src/gdi gdi.f,NONE,1.1 gdiBase.f,NONE,1.1 gdiBitmap.f,NONE,1.1 gdiBrush.f,NONE,1.1 gdiDC.f,NONE,1.1 gdiFont.f,NONE,1.1 gdiMetafile.f,NONE,1.1 gdiMetafileDc.f,NONE,1.1 gdiPen.f,NONE,1.1 gdiStruct.f,NONE,1.1 gdiWindowDc.f,NONE,1.1

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src/gdi
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13139/src/gdi

Added Files:
	gdi.f gdiBase.f gdiBitmap.f gdiBrush.f gdiDC.f gdiFont.f 
	gdiMetafile.f gdiMetafileDc.f gdiPen.f gdiStruct.f 
	gdiWindowDc.f 
Log Message:
- Added my GDI class library to the CVS
- WinDC and Font classes rewritten to use the GDI class library
- Added some demo's whitch are using the GDI class library

--- NEW FILE: gdiStruct.f ---
\ gdiStruct.f
\
\ Written by Dirk Busch
\ Sonntag, Oktober 09 2005
\ Licence: Public Domain

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

WinLibrary COMDLG32.DLL

internal
external

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Wrapper class for a POINT-Struct
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
:class gdiPOINT <super object

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

:M ClassInit:   ( -- )
        ClassInit: super

        0 to x
        0 to y
        ;M

:M GetX:        ( -- x )        x ;M
:M GetY:        ( -- y )        y ;M
:M SetX:        ( x -- )        to x ;M
:M SetY:        ( y -- )        to y ;M

:M Addr:        ( -- addr )     &POINT ;M
:M Size:        ( -- size )     sizeof(POINT) ;M

;class

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Wrapper class for a COLOREF-Struct
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:class gdiCOLORREF <super object

Record: &COLORREF
        byte r
        byte g
        byte b
        byte alpha
;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)

64 bytes CustomColors

:M ClassInit:   ( -- )
        ClassInit: super

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

        \ 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

        \ 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 + !
        ;M

:M SetAlpha:    ( alpha -- )    to alpha ;M
:M SetRValue:   ( r -- )        to r ;M
:M SetGValue:   ( g -- )        to g ;M
:M SetBValue:   ( b -- )        to b ;M
:M GetAlpha:    ( alpha -- )    alpha ;M
:M GetRValue:   ( -- r )        r ;M
:M GetGValue:   ( -- g )        g ;M
:M GetBValue:   ( -- b )        b ;M
:M SetColor:    ( colorref -- ) 0x00ffffff and &COLORREF ! ;M
:M SetSysColor: ( n -- )        call GetSysColor &COLORREF ! ;M
:M GetColor:    ( -- colorref ) &COLORREF @ 0x00ffffff and ;M
:M SetRGB:      ( r g b -- )    SetBValue: self SetGValue: self SetRValue: self ;M

:M Addr:        ( -- addr )     &COLORREF ;M
:M Size:        ( -- size )     sizeof(COLORREF) ;M

:M Choose:      ( hWnd -- f )
        to hwndOwner
        GetColor: self to rgbResult
        &CHOOSECOLOR call ChooseColor
        IF   rgbResult SetColor: self true
        else false
        then ;M

;class

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Wrapper class for a RGBQUAD-Struct
\
\ The RGBQUAD structure describes a color consisting of relative intensities
\ of red, green, and blue.
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:class gdiRGBQUAD <super gdiCOLORREF

:M SetAlpha:    ( alpha -- )    drop ;M
:M GetAlpha:    ( -- alpha )    0 ;M

;class

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Wrapper class for a SIZE-struct
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:class gdiSIZE <super object

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

:M ClassInit:   ( -- )
        ClassInit: super

        0 to cx
        0 to cy
        ;M

:M GetX:        ( -- x )        cx ;M
:M GetY:        ( -- y )        cy ;M
:M SetX:        ( x -- )        to cx ;M
:M SetY:        ( y -- )        to cy ;M

:M Addr:        ( -- addr )     &SIZE ;M
:M Size:        ( -- size )     sizeof(SIZE) ;M

;class

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Wrapper class for a TEXTMETRIC-struct
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:class gdiTEXTMETRIC <super object

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 -- ) to tmHeight ;M
:M SetAscent:            ( n -- ) to tmAscent ;M
:M SetDescent:           ( n -- ) to tmDescent ;M
:M SetInternalLeading:   ( n -- ) to tmInternalLeading ;M
:M SetExternalLeading:   ( n -- ) to tmExternalLeading ;M
:M SetAveCharWidth:      ( n -- ) to tmAveCharWidth ;M
:M SetMaxCharWidth:      ( n -- ) to tmMaxCharWidth ;M
:M SetWeight:            ( n -- ) to tmWeight ;M
:M SetOverhang:          ( n -- ) to tmOverhang ;M
:M SetDigitizedAspectX:  ( n -- ) to tmDigitizedAspectX ;M
:M SetDigitizedAspectY:  ( n -- ) to tmDigitizedAspectY ;M
:M SetFirstChar:         ( n -- ) to tmFirstChar ;M
:M SetLastChar:          ( n -- ) to tmLastChar ;M
:M SetDefaultChar:       ( n -- ) to tmDefaultChar ;M
:M SetBreakChar:         ( n -- ) to tmBreakChar ;M
:M SetItalic:            ( n -- ) to tmItalic ;M
:M SetUnderlined:        ( n -- ) to tmUnderlined ;M
:M SetStruckOut:         ( n -- ) to tmStruckOut ;M
:M SetPitchAndFamily:    ( n -- ) to tmPitchAndFamily ;M
:M SetCharSet:           ( n -- ) to tmCharSet ;M

:M GetHeight:            ( -- n ) tmHeight ;M
:M GetAscent:            ( -- n ) tmAscent ;M
:M GetDescent:           ( -- n ) tmDescent ;M
:M GetInternalLeading:   ( -- n ) tmInternalLeading ;M
:M GetExternalLeading:   ( -- n ) tmExternalLeading ;M
:M GetAveCharWidth:      ( -- n ) tmAveCharWidth ;M
:M GetMaxCharWidth:      ( -- n ) tmMaxCharWidth ;M
:M GetWeight:            ( -- n ) tmWeight ;M
:M GetOverhang:          ( -- n ) tmOverhang ;M
:M GetDigitizedAspectX:  ( -- n ) tmDigitizedAspectX ;M
:M GetDigitizedAspectY:  ( -- n ) tmDigitizedAspectY ;M
:M GetFirstChar:         ( -- n ) tmFirstChar ;M
:M GetLastChar:          ( -- n ) tmLastChar ;M
:M GetDefaultChar:       ( -- n ) tmDefaultChar ;M
:M GetBreakChar:         ( -- n ) tmBreakChar ;M
:M GetItalic:            ( -- n ) tmItalic ;M
:M GetUnderlined:        ( -- n ) tmUnderlined ;M
:M GetStruckOut:         ( -- n ) tmStruckOut ;M
:M GetPitchAndFamily:    ( -- n ) tmPitchAndFamily ;M
:M GetCharSet:           ( -- n ) tmCharSet ;M

:M Addr:                 ( -- addr ) &TEXTMETRIC ;M
:M Size:                 ( -- size ) sizeof(TEXTMETRIC) ;M

;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

--- NEW FILE: gdi.f ---
\ gdi.f
\
\ Written: Sonntag, Oktober 09 2005 by Dirk Busch
\ Changed: Samstag, Oktober 29 2005 by Dirk Busch
\
\ Licence: Public Domain
\
\ Missing:      Clipping support
\               Colors (Pallette) support
\               Region support
\               Printing support

cr .( Loading GDI class library...)

needs gdi/gdiBase.f
needs gdi/gdiPen.f
needs gdi/gdiBrush.f
needs gdi/gdiFont.f
needs gdi/gdiBitmap.f
needs gdi/gdiMetafile.f
needs gdi/gdiDc.f
needs gdi/gdiWindowDc.f
needs gdi/gdiMetafileDC.f

--- NEW FILE: gdiBitmap.f ---
\ gdiBitmap.f
\
\ Written by Dirk Busch
\ Sonntag, Oktober 09 2005
\ Licence: Public Domain

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

needs gdiBase.f

internal
external

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Bitmap class
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

:class gdiBitmap <super gdiObject

gdiSize SIZE

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

\ The CreateBitmap function creates a bitmap with the specified width, height,
\ and color format (color planes and bits-per-pixel).
\
\ Width  Specifies the bitmap width, in pixels.
\ Height Specifies the bitmap height, in pixels.
\ Planes Specifies the number of color planes used by the device.
\ BitsPerPel Specifies the number of bits required to identify the color of a
\            single pixel.
\ pBits Pointer to an array of color data used to set the colors in a rectangle
\       of pixels. Each scan line in the rectangle must be word aligned (scan
\       lines that are not word aligned must be padded with zeros). If this
\       parameter is NULL, the contents of the new bitmap is undefined.
\
\ After a bitmap is created, it can be selected into a device context by calling
\ the SelectObject function. The CreateBitmap function can be used to create color
\ bitmaps. However, for performance reasons applications should use CreateBitmap
\ to create monochrome bitmaps and CreateCompatibleBitmap to create color bitmaps.
\ When a color bitmap returned from CreateBitmap is selected into a device context,
\ the system must ensure that the bitmap matches the format of the device context
\ it is being selected into. Since CreateCompatibleBitmap takes a device context,
\ it returns a bitmap that has the same format as the specified device context.
\ Because of this, subsequent calls to SelectObject are faster than with a color
\ bitmap returned from CreateBitmap.
\
\ If the bitmap is monochrome, zeros represent the foreground color and ones represent
\ the background color for the destination device context.
\
\ If an application sets the nWidth or nHeight parameters to zero, CreateBitmap
\ returns the handle to a 1-by-1 pixel, monochrome bitmap.
\
\ When you no longer need the bitmap, call the Destroy: method to delete it.
\
\ Windows 95/98: The created bitmap cannot exceed 16MB in size
:M CreateBitmap: ( Width Height Planes BitsPerPel pBits -- f )
        5reverse call CreateBitmap SetHandle: super
        Valid?: super ;M

\ The CreateBitmapIndirect function creates a bitmap with the specified width,
\ height, and color format (color planes and bits-per-pixel).
\ pBitmap Pointer to a BITMAP structure that contains information about the
\ bitmap. If an application sets the bmWidth or bmHeight members to zero,
\ CreateBitmapIndirect returns the handle to a 1-by-1 pixel, monochrome bitmap.
:M CreateBitmapIndirect: ( pBitmap -- f )
        call CreateBitmapIndirect SetHandle: super
        Valid?: super ;M

\ The CreateCompatibleBitmap function creates a bitmap compatible with the device
\ that is associated with the specified device context.
\
\ The color format of the bitmap created by the CreateCompatibleBitmap function
\ matches the color format of the device identified by the hdc parameter. This
\ bitmap can be selected into any memory device context that is compatible with
\ the original device.
\
\ Because memory device contexts allow both color and monochrome bitmaps, the format
\ of the bitmap returned by the CreateCompatibleBitmap function differs when the
\ specified device context is a memory device context. However, a compatible bitmap
\ that was created for a nonmemory device context always possesses the same color
\ format and uses the same color palette as the specified device context.
\
\ Note: When a memory device context is created, it initially has a 1-by-1 monochrome
\ bitmap selected into it. If this memory device context is used in CreateCompatibleBitmap,
\ the bitmap that is created is a monochrome bitmap. To create a color bitmap, use the
\ hDC that was used to create the memory device context, as shown in the following code:
\
\     HDC memDC = CreateCompatibleDC ( hDC );
\     HBITMAP memBM = CreateCompatibleBitmap ( hDC );
\     SelectObject ( memDC, memBM );
\
\ If an application sets the nWidth or nHeight parameters to zero, CreateCompatibleBitmap
\ returns the handle to a 1-by-1 pixel, monochrome bitmap.
\
\ If a DIB section, which is a bitmap created by the CreateDIBSection function, is selected
\ into the device context identified by the hdc parameter, CreateCompatibleBitmap creates a
\ DIB section.
\
\ When you no longer need the bitmap, call the DeleteObject function to delete it.
\
\ Windows 95/98: The created bitmap cannot exceed 16MB in size.
:M CreateCompatibleBitmap: ( Width Height hDC -- f )
        GetGdiObjectHandle >r swap r> call CreateCompatibleBitmap SetHandle: super
        Valid?: super ;M

\ The CreateDIBitmap function creates a device-dependent bitmap (DDB) from a DIB and,
\ optionally, sets the bitmap bits.
\
\ lpbmih Pointer to a bitmap information header structure, which may be one of those
\ shown in the following table. Operating system Bitmap information header
\       Windows NT 3.51 and earlier     BITMAPINFOHEADER
\       Windows NT 4.0 and Windows 95   BITMAPV4HEADER          NOT SUPPORTED !!!
\       Windows 2000 and Windows 98     BITMAPV5HEADER          NOT SUPPORTED !!!
\
\ If fdwInit is CBM_INIT, the function uses the bitmap information header structure to
\ obtain the desired width and height of the bitmap as well as other information. Note
\ that a positive value for the height indicates a bottom-up DIB while a negative value
\ for the height indicates a top-down DIB. Calling CreateDIBitmap with fdwInit as CBM_INIT
\ is equivalent to calling the CreateCompatibleBitmap function to create a DDB in the format
\ of the device and then calling the SetDIBits function to translate the DIB bits to the DDB.
\
\ fdwInit Specifies how the system initializes the bitmap bits. The following values is defined.
\ Value Meaning CBM_INIT If this flag is set, the system uses the data pointed to by the lpbInit
\ and lpbmi parameters to initialize the bitmap's bits. If this flag is clear, the data pointed
\ to by those parameters is not used.
\
\ If fdwInit is zero, the system does not initialize the bitmap's bits.
\
\ lpbInit Pointer to an array of bytes containing the initial bitmap data. The format of the data
\ depends on the biBitCount member of the BITMAPINFO structure to which the lpbmi parameter points.
\
\ lpbmi Pointer to a BITMAPINFO structure that describes the dimensions and color format of the
\ array pointed to by the lpbInit parameter.
\
\ fuUsage Specifies whether the bmiColors member of the BITMAPINFO structure was initialized and,
\ if so, whether bmiColors contains explicit red, green, blue (RGB) values or palette indexes.
\ The fuUsage parameter must be one of the following values. Value Meaning
\ DIB_PAL_COLORS A color table is provided and consists of an array of 16-bit indexes into the
\                logical palette of the device context into which the bitmap is to be selected.
\ DIB_RGB_COLORS A color table is provided and contains literal RGB values.
:M CreateDIBitmap: ( pbmih fdwInit pbInit pbmi fuUsage hdc -- f )
        GetGdiObjectHandle >r 5reverse r> call CreateDIBitmap SetHandle: super
        Valid?: super ;M

\ The CreateDIBSection function creates a DIB that applications can write to directly. The function
\ gives you a pointer to the location of the bitmap's bit values. You can supply a handle to a
\ file-mapping object that the function will use to create the bitmap, or you can let the system
\ allocate the memory for the bitmap.
\
\ hdc Handle to a device context. If the value of iUsage is DIB_PAL_COLORS, the function uses
\ this device context's logical palette to initialize the DIB's colors.
\
\ pbmi Pointer to a BITMAPINFO structure that specifies various attributes of the DIB, including
\ the bitmap's dimensions and colors.
\
\ iUsage Specifies the type of data contained in the bmiColors array member of the BITMAPINFO
\ structure pointed to by pbmi (either logical palette indexes or literal RGB values). The
\ following values are defined. Value Meaning
\ DIB_PAL_COLORS The bmiColors member is an array of 16-bit indexes into the logical palette of
\                the device context specified by hdc.
\ DIB_RGB_COLORS The BITMAPINFO structure contains an array of literal RGB values.
\
\ ppvBits Pointer to a variable that receives a pointer to the location of the DIB's bit values.
\
\ hSection Handle to a file-mapping object that the function will use to create the DIB. This
\ parameter can be NULL. If hSection is not NULL, it must be a handle to a file-mapping object
\ created by calling the CreateFileMapping function with the PAGE_READWRITE or PAGE_WRITECOPY flag.
\ Read-only DIB sections are not supported. Handles created by other means will cause CreateDIBSection
\ to fail. If hSection is not NULL, the CreateDIBSection function locates the bitmap's bit values at
\ offset dwOffset in the file-mapping object referred to by hSection. An application can later retrieve
\ the hSection handle by calling the GetObject function with the HBITMAP returned by CreateDIBSection.
\ If hSection is NULL, the system allocates memory for the DIB. In this case, the CreateDIBSection
\ function ignores the dwOffset parameter. An application cannot later obtain a handle to this memory.
\ The dshSection member of the DIBSECTION structure filled in by calling the GetObject function will
\ be NULL.
\
\ dwOffset Specifies the offset from the beginning of the file-mapping object referenced by hSection
\ where storage for the bitmap's bit values is to begin. This value is ignored if hSection is NULL.
\ The bitmap's bit values are aligned on doubleword boundaries, so dwOffset must be a multiple of the
\ size of a DWORD.
:M CreateDIBSection: ( pbmi iUsage ppvBits hSection dwOffset hdc -- f )
        GetGdiObjectHandle >r 5reverse r> call CreateDIBSection SetHandle: super
        Valid?: super ;M

\ The SetBitmapDimension function assigns preferred dimensions to a bitmap. These dimensions can be
\ used by applications; however, they are not used by the system.
\ Width Specifies the width, in 0.1-millimeter units, of the bitmap.
\ Height Specifies the height, in 0.1-millimeter units, of the bitmap.
\ An application can retrieve the dimensions assigned to a bitmap with the SetBitmapDimensionEx function
\ by calling the GetBitmapDimension function.
\ The bitmap identified by hBitmap cannot be a DIB section, which is a bitmap created by the
\ CreateDIBSection function. If the bitmap is a DIB section, the SetBitmapDimension function fails.
:M SetBitmapDimension: ( width height -- oldwidth oldheight )
        Addr: SIZE 3reverse hObject call SetBitmapDimensionEx ?win-error
        GetX: SIZE GetY: SIZE ;M

\ The GetBitmapDimension function retrieves the dimensions of a bitmap. The retrieved dimensions must
\ have been set by the SetBitmapDimension function.
\ The function returns the height and width of the bitmap, in .01-mm units.
:M GetBitmapDimension: ( -- width height )
        Addr: SIZE hObject call GetBitmapDimensionEx ?win-error
        GetX: SIZE GetY: SIZE ;M

\ SetDIBits
\ GetDIBits
\ LoadBitmap
\ MaskBlt
\ PlgBlt

;class

module

--- NEW FILE: gdiBrush.f ---
\ gdiBrush.f
\
\ Written by Dirk Busch
\ Sonntag, Oktober 09 2005
\ Licence: Public Domain

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

needs gdiBase.f

internal
external

\ ----------------------------------------------------------------------
\ Base class for all brush objects
\ ----------------------------------------------------------------------
internal

:class gdiBrush <super gdiObject

gdiPoint origin

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

:M SetOrigin:   { xOrg yOrg hdc -- }
        NULL yOrg xOrg hdc GetGdiObjectHandle call SetBrushOrgEx ?win-error ;M

:M GetOrigin:   ( hdc -- xOrg yOrg )
        Addr: origin call GetBrushOrgEx 0=
        if   -1 -1 \ error
        else GetX: origin GetY: origin
        then ;M

\ The Create function creates a logical brush that has the specified style,
\ color, and pattern.
\ lplb Pointer to a LOGBRUSH structure that contains information about the
\ brush.
:M Create:      ( lplb -- f )
        call CreateBrushIndirect SetHandle: super
        Valid?: super ;M

;class

external

\ ----------------------------------------------------------------------
\ Solid brush class
\ ----------------------------------------------------------------------
:class gdiSolidBrush <super gdiBrush

\ Color of the brush.
gdiCOLORREF Color

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

:M SetRValue:   ( r -- )        SetRValue: Color ;M
:M SetGValue:   ( g -- )        SetGValue: Color ;M
:M SetBValue:   ( b -- )        SetBValue: Color ;M
:M SetRGB:      ( r g b -- )    SetRGB: Color ;M
:M SetColor:    ( colorref -- ) SetColor: Color ;M
:M SetSysColor: ( n -- )        SetSysColor: Color ;M
:M ChooseColor: ( hWnd -- f )   Choose: Color ;M

:M GetRValue:   ( -- r )        GetRValue: Color ;M
:M GetGValue:   ( -- g )        GetGValue: Color ;M
:M GetBValue:   ( -- b )        GetBValue: Color ;M
:M GetColor:    ( -- colorref ) GetColor: Color ;M

:M Create:      ( -- f )
        GetColor: color call CreateSolidBrush SetHandle: super
        Valid?: super ;M

;class

\ ----------------------------------------------------------------------
\ Hatch brush class
\ ----------------------------------------------------------------------
:class gdiHatchBrush <super gdiSolidBrush

\ Style of the brush. Possible values are:
\ HS_BDIAGONAL  45-degree downward left-to-right hatch
\ HS_CROSS      Horizontal and vertical crosshatch
\ HS_DIAGCROSS  45-degree crosshatch
\ HS_FDIAGONAL  45-degree upward left-to-right hatch
\ HS_HORIZONTAL Horizontal hatch
\ HS_VERTICAL   Vertical hatch
int Style

:M ClassInit:   ( -- )
        ClassInit: super
        HS_BDIAGONAL to style
        ;M

:M SetStyle:    ( style -- ) to style ;M
:M GetStyle:    ( -- style ) style ;M

:M Create:      ( -- f )
        GetColor: color Style call CreateHatchBrush SetHandle: super
        Valid?: super ;M

;class

\ ----------------------------------------------------------------------
\ Pattern brush class
\ ----------------------------------------------------------------------
:class gdiPatternBrush <super gdiBrush

\ Bitmap of the brush.
int Bitmap

:M ClassInit:   ( -- )
        ClassInit: super
        0 to Bitmap
        ;M

:M SetBitmap:   ( Bitmap -- ) to Bitmap ;M
:M GetBitmap:   ( -- Bitmap ) Bitmap ;M

:M Create:      ( -- f )
        Bitmap ?dup if call CreatePatternBrush SetHandle: super then
        Valid?: super ;M

;class

\ ----------------------------------------------------------------------
\ DIBPattern brush class
\ ----------------------------------------------------------------------
:class gdiDIBPatternBrush <super gdiBrush

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

\ The Create function creates a logical brush that has the pattern specified
\ by the device-independent bitmap (DIB).
\
\ lpPackedDIB Pointer to a packed DIB consisting of a BITMAPINFO structure immediately
\ followed by an array of bytes defining the pixels of the bitmap.
\ Windows 95: Creating brushes from bitmaps or DIBs larger than 8 by 8 pixels
\ is not supported. If a larger bitmap is specified, only a portion of the bitmap
\ is used.
\ Windows NT/ 2000 and Windows 98: Brushes can be created from bitmaps or DIBs
\ larger than 8 by 8 pixels.
\
\ iUsage Specifies whether the bmiColors member of the BITMAPINFO structure contains
\ a valid color table and, if so, whether the entries in this color table contain
\ explicit red, green, blue (RGB) values or palette indexes. The iUsage parameter
\ must be one of the following values.
\ DIB_PAL_COLORS A color table is provided and consists of an array of 16-bit indexes
\                into the logical palette of the device context into which the brush
\                is to be selected.
\ DIB_RGB_COLORS A color table is provided and contains literal RGB values.
:M Create:      ( lpPackedDIB iUsage -- f )
        call CreateDIBPatternBrushPt SetHandle: super
        Valid?: super ;M

;class

module

--- NEW FILE: gdiDC.f ---
\ gdiDC.f
\
\ Written by Dirk Busch
\ Sonntag, Oktober 09 2005
\ Licence: Public Domain
\
\ Missing: - WorldTransform support

cr .( Loading GDI class library - Device context...)

needs gdiBase.f

internal

8 constant TAB-CHAR-WIDTH

external

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
[...1244 lines suppressed...]
\ StretchBlt
\ StretchDIBits
\ TransparentBlt W98 and w2k or later
\ PatBlt
\ AngleArc
\ SetMiterLimit
\ GetMiterLimit

\ ----------------------------------------------------------------------
\ ----------------------------------------------------------------------

:M ClassInit:   ( -- )
        ClassInit: super
        8 to tabwidth
        DefaultTabs: self
        ;M

;class

module

--- NEW FILE: gdiPen.f ---
\ gdiPen.f
\
\ Written by Dirk Busch
\ Sonntag, Oktober 09 2005
\ Licence: Public Domain
\
\ TODO: finish gdiGeometricPen class

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

needs gdiBase.f

internal
external

\ ----------------------------------------------------------------------
\ Pen class - for cosmetic pen's
\ ----------------------------------------------------------------------
:class gdiPen <super gdiObject

\ Syle of the pen. Possible values are:
\ 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 in any GDI drawing
\                function that takes a bounding rectangle, 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.
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:   ( -- )
        ClassInit: super

        PS_SOLID to Style
        1 to Width
        ;M

:M SetStyle:    ( style -- )    to style ;M
:M SetWidth:    ( width -- )    0 max to width ;M

:M SetRValue:   ( r -- )        SetRValue: Color ;M
:M SetGValue:   ( g -- )        SetGValue: Color ;M
:M SetBValue:   ( b -- )        SetBValue: Color ;M
:M SetRGB:      ( r g b -- )    SetRGB: Color ;M
:M SetColor:    ( colorref -- ) SetColor: Color ;M
:M SetSysColor: ( n -- )        SetSysColor: Color ;M
:M ChooseColor: ( hWnd -- f )   Choose: Color ;M

:M GetStyle:    ( -- style )    style ;M
:M GetWidth:    ( -- width )    width ;M

:M GetRValue:   ( -- r )        GetRValue: Color ;M
:M GetGValue:   ( -- g )        GetGValue: Color ;M
:M GetBValue:   ( -- b )        GetBValue: Color ;M
:M GetColor:    ( -- colorref ) GetColor: Color ;M

:M Create:      ( -- f )
        GetColor: color width style call CreatePen SetHandle: super
        Valid?: super ;M

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

;class

\ ----------------------------------------------------------------------
\ GeometricPen class - for geometric pen's
\ ----------------------------------------------------------------------
:class gdiGeometricPen <super gdiObject

\ ExtCreatePen

;class

module

--- NEW FILE: gdiWindowDc.f ---
\ gdiWindowDc.f
\
\ Written by Dirk Busch
\ Sonntag, Oktober 09 2005
\ Licence: Public Domain

cr .( Loading GDI class library - Window device context...)

needs gdiDC.f

internal
external

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Window device context class
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
:class gdiWindowDC <super gdiDC

int hWnd \ handle of the window in which this device context is used

:M ClassInit:   ( -- )
        ClassInit: super
        0 to hWnd
        ;M

\ The ReleaseWndDC: function releases a device context (DC), freeing it
\ for use by other applications. The effect of the ReleaseDC function depends
\ on the type of DC. It frees only common and window DCs. It has no effect on
\ class or private DCs.
:M Release: ( -- )
        hWnd ?dup
        if   hObject swap call ReleaseDC ?win-error
             0 to hWnd
        then ;M

:M Destroy:     ( -- )
        Release: self
        Destroy: super
        ;M

: SetWindow     ( hWnd -- f )
        Release: self
        dup to hWnd call IsWindow ;

: SetHandle     ( hDC -- f )
        SetHandle: super
        Valid?: super ;

\ The GetDC method retrieves a handle to a display device context
\ (DC) for the client area of a specified window.
:M GetDC:    ( hWnd -- f )
        SetWindow
        if   hWnd call GetDC
        else NULL
        then SetHandle
        ;M

\ The GetDCEx function retrieves a handle to a display device context
\ (DC) for the client area of a specified window or for the entire screen.
\ You can use the returned handle in subsequent GDI functions to draw in the DC.
\
\ This function is an extension to the GetDC function, which gives an application
\ more control over how and whether clipping occurs in the client area.
\
\ hrgnClip  Specifies a clipping region that may be combined with the visible region
\ of the DC. If the value of flags is DCX_INTERSECTRGN or DCX_EXCLUDERGN, then the
\ operating system assumes ownership of the region and will automatically delete it
\ when it is no longer needed. In this case, applications should not use the region
\ not even delete it after a successful call to GetDCEx.
\
\ flags Specifies how the DC is created. This parameter can be one or more of the
\ following values.
\ DCX_WINDOW            Returns a DC that corresponds to the window rectangle rather
\                       than the client rectangle.
\ DCX_CACHE             Returns a DC from the cache, rather than the OWNDC or CLASSDC
\                       window. Essentially overrides CS_OWNDC and CS_CLASSDC.
\ DCX_PARENTCLIP        Uses the visible region of the parent window. The parent's
\                       WS_CLIPCHILDREN and CS_PARENTDC style bits are ignored. The
\                       origin is set to the upper-left corner of the window identified
\                       by hWnd.
\ DCX_CLIPSIBLINGS      Excludes the visible regions of all sibling windows above the
\                       window identified by hWnd.
\ DCX_CLIPCHILDREN      Excludes the visible regions of all child windows below the
\                       window identified by hWnd.
\ DCX_NORESETATTRS      Does not reset the attributes of this DC to the default attributes
\                       when this DC is released.
\ DCX_LOCKWINDOWUPDATE  Allows drawing even if there is a LockWindowUpdate call in effect
\                       that would otherwise exclude this window. Used for drawing during
\                       tracking.
\ DCX_EXCLUDERGN        The clipping region identified by hrgnClip is excluded from the
\                       visible region of the returned DC.
\ DCX_INTERSECTRGN      The clipping region identified by hrgnClip is intersected with the
\                       visible region of the returned DC.
\ DCX_VALIDATE          When specified with DCX_INTERSECTUPDATE, causes the DC to be
\                       completely validated. Using this function with both DCX_INTERSECTUPDATE
\                       and DCX_VALIDATE is identical to using the BeginPaint function.
:M GetDCEx:     ( hrgnClip flags hWnd -- f )
        SetWindow
        if   swap hWnd call GetDCEx
        else NULL
        then SetHandle
        ;M

\ The GetWindowDC method retrieves the device context (DC) for the entire
\ window, including title bar, menus, and scroll bars. A window device
\ context permits painting anywhere in a window, because the origin of
\ the device context is the upper-left corner of the window instead of
\ the client area.
:M GetWindowDC: ( hWnd -- f )
        SetWindow
        if   hWnd call GetWindowDC
        else NULL
        then SetHandle
        ;M

\ The GetDCOrgEx function retrieves the final translation origin for a specified device
\ context (DC). The final translation origin specifies an offset that the system uses to
\ translate device coordinates into client coordinates (for coordinates in an application's
\ window).
:M GetDCOrg:    ( -- x y )
        Addr: POINT hObject call GetDCOrgEx ?win-error
        GetX: POINT GetY: POINT ;M

;class

module

--- NEW FILE: gdiMetafile.f ---
\ gdiMetafile.f
\
\ Written by Dirk Busch
\ Sonntag, Oktober 09 2005
\ Licence: Public Domain

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

needs gdiBase.f
needs gdiDC.f

internal
external

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Metafile class - This class only support's enhanced metafiles (emf) !
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
:class gdiMetafile <super gdiObject

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

\ The DeleteEnhMetaFile function deletes an enhanced-format metafile
\ or an enhanced-format metafile handle.
:M Destroy:     ( -- )
        hObject ?dup
        if   call DeleteEnhMetaFile ?win-error
             0 to hObject
        then ;M

:M SetHandle: ( hMF -- )
        Destroy: self to hObject ;M

\ Create a copy of the metafile in memory
:M Copy:        ( -- hCopy )
        hObject
        if   0 hObject call CopyEnhMetaFile
        else null
        then ;M

: FileName      ( addr len -- addr1 )
        pad place pad +null pad 1+ ;

\ Load a metafile from a file
:M Load:        ( addr len -- f )
        FileName call GetEnhMetaFile SetHandle: self
        Valid?: super ;M

\ Save the metafile in a file
:M Save:        ( addr len -- f )
        hObject
        if   FileName hObject call CopyEnhMetaFile dup
             if   call DeleteEnhMetaFile ?win-error true
             else false
             then
        else 2drop false
        then ;M

\ Play the metafile in a rectangle
:M PlayInRect:  ( left top right bottom hDestDC -- )
        GetGdiObjectHandle >r SetRect: TempRect AddrOf: TempRect
        hObject r> call PlayEnhMetaFile ?win-error ;M

\ Copy the metafile to the clipboard
:M CopyToClipboard: ( -- )
        hObject
        if   null call OpenClipboard ?win-error
             call EmptyClipboard ?win-error
             null hObject call CopyEnhMetaFile
             CF_ENHMETAFILE call SetClipboardData ?win-error
             call CloseClipboard ?win-error
        then ;M

\ Get a metafile from the clipboard
:M GetFromClipboard: ( -- )
	null call OpenClipboard ?win-error
	CF_ENHMETAFILE call GetClipboardData
	call CloseClipboard ?win-error
        ?dup
        if   null swap call CopyEnhMetaFile
             SetHandle: self
        then ;M

\ The GetMetaFileHeader function retrieves the record containing the header
\ for the specified enhanced-format metafile.
\ pemh  Pointer to an ENHMETAHEADER structure that receives the header record.
\ If this parameter is NULL, the function returns the size of the header record.
\ size Specifies the size, in bytes, of the buffer to receive the data. Only this
\ many bytes will be copied.
:M GetFileHeader:       ( pemh size -- n )
        hObject call GetEnhMetaFileHeader ;M

\ The GetPaletteEntries function retrieves optional palette entries from the
\ specified enhanced metafile.
\ cEntries  Specifies the number of entries to be retrieved from the optional
\ palette.
\ lppe Pointer to an array of PALETTEENTRY structures that receives the palette
\ colors. The array must contain at least as many structures as there are entries
\ specified by the cEntries parameter.
\ If the array pointer is NULL and the enhanced metafile contains an optional palette,
\ the return value is the number of entries in the enhanced metafile's palette; if
\ the array pointer is a valid pointer and the enhanced metafile contains an optional
\ palette, the return value is the number of entries copied; if the metafile does not
\ contain an optional palette, the return value is zero. Otherwise, the return value
\ is GDI_ERROR.
:M GetPaletteEntries:   ( cEntries lppe -- n )
        swap hObject call GetEnhMetaFilePaletteEntries ;M

;class

module

--- NEW FILE: gdiBase.f ---
\ gdiBase.f
\
\ Written by Dirk Busch
\ Sonntag, Oktober 09 2005
\ Licence: Public Domain

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

needs gdiStruct.f

internal
external

in-application

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

[undefined] 3reverse [if]
: 3reverse ( n1 n2 n3 -- n3 n2 n1 )
        3 S-REVERSE ;
[then]

[undefined] 4reverse [if]
: 4reverse ( n1 n2 n3 n4 -- n4 n3 n2 n1 )
        4 S-REVERSE ;
[then]

[undefined] 5reverse [if]
: 5reverse ( n1 n2 n3 n4 n5 -- n5 n4 n3 n2 n1 )
        5 S-REVERSE ;
[then]

[undefined] 6reverse [if]
: 6reverse ( n1 n2 n3 n4 n5 n6 -- n6 n5 n4 n3 n2 n1 )
        6 S-REVERSE ;
[then]

[undefined] 8reverse [if]
: 8reverse ( n1 n2 n3 n4 n5 n6 n7 n8 -- n8 n7 n6 n5 n4 n3 n2 n1 )
        8 S-REVERSE ;
[then]

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

internal

VARIABLE gdi-object-link
         gdi-object-link OFF

external

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Base class for all GDI Objects
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
:class GdiObject <super object

int hObject \ handle of the GDI object

:M ZeroHandle:  ( -- )
        0 to hObject ;M

:M ClassInit:   ( -- )
        ClassInit: super

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

\ The GetType method retrieves the type of the specified object.
\ Possible return values are:
\ 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
:M GetType:     ( -- n )
        hObject call GetObjectType ;M

\ The GetObject function retrieves information for the specified graphics object.
\ If the function succeeds, and lpvObject is a valid pointer, the return value is
\ the number of bytes stored into the buffer.
\ 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.
:M GetObject:   ( cbBuffer lpvObject -- n )
        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:     ( -- )
        Destroy?
        if   hObject call DeleteObject ?win-error
        then 0 to hObject
        ;M

:M GetHandle:   ( -- hObject )
        hObject ;M

:M SetHandle:   ( hObject -- )
        Destroy: self
        to hObject ;M

\ Check if this object is valid
:M Valid?:      ( -- f )
        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 font handles
        [getmethod] ZeroHandle: GdiObject do-objects ;

: destroy-gdi-objects   ( -- ) \ destroy all font handles
        [getmethod] Destroy: GdiObject do-objects ;

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

;class

in-system

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Displays the current set of defined gdi objects
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
: .gdi-objects  ( -- )

                gdi-object-link @
                begin   dup
                while   dup cell+ @
                        cell - body> .NAME
                        12 #tab space 12 ?cr
                        @
                repeat  drop ;

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

: ?IsGdiObject  ( a1 -- f )
                >r gdi-object-link @
                begin   dup
                while   dup cell+ @ r@ =  \ match this gdi object?
                        if   drop r>drop true EXIT \ leave test, passed
                        then @
                repeat  drop
                r>drop false ;

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

in-system

: (?GdiCheck)   ( a1 -- a1 )
                dup ?IsGdiObject 0=
                if   forth-io .rstack
                     true Abort" This is not a GDI Object!"
                then ;

in-application

: ?GdiCheck     ( a1 -- a1 )    \ verify that a1 is a gdi object address
                TURNKEYED? ?win-error-enabled 0= or ?EXIT \ leave if error checking is not enabled
\in-system-ok   (?GdiCheck) ;

module

--- NEW FILE: gdiMetafileDc.f ---
\ gdiMetafileDC.f
\
\ Written by Dirk Busch
\ Sonntag, Oktober 09 2005
\ Licence: Public Domain

cr .( Loading GDI class library - Metafile device context...)

needs gdiDC.f
needs gdiMetafile.f

internal
external

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ Metafile device context class
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
:class gdiMetafileDC <super gdiDC

RECTANGLE   MetaRect
create      MetaName maxstring allot
gdiMetafile Metafile

\ Specify the dimensions (in .01-millimeter units) of the picture to be
\ stored in the enhanced metafile.
:M SetRect:     ( left top right bottom -- )
        SetRect: MetaRect ;M

:M ClassInit:   ( -- )
        ClassInit: super
        0 MetaName !
        0 0 10000 10000 SetRect: self
        ;M

\ Calc the dimensions (in .01-millimeter units) of the picture to be
\ stored in the enhanced metafile.
:M CalcMetaRect: { left top right bottom hDC \ iWidthMM iHeightMM iWidthPels iHeightPels -- }
        hDC GetGdiObjectHandle to hDC

        \ Determine the picture frame dimensions.
        \ iWidthMM    is the display width in millimeters.
        \ iHeightMM   is the display height in millimeters.
        \ iWidthPels  is the display width in pixels.
        \ iHeightPels is the display height in pixels
        HORZSIZE hDC call GetDeviceCaps to iWidthMM
        HORZRES  hDC call GetDeviceCaps to iWidthPels
        VERTSIZE hDC call GetDeviceCaps to iHeightMM
        VERTRES  hDC call GetDeviceCaps to iHeightPels

        \ Convert client coordinates to .01-mm units.
        \ Use iWidthMM, iWidthPels, iHeightMM, and  iHeightPels to
        \ determine the number of  .01-millimeter units per pixel in
        \ the x- and y-directions.
        left   iWidthMM  * 100 * iWidthPels  /
        top    iHeightMM * 100 * iHeightPels /
        right  iWidthMM  * 100 * iWidthPels  /
        bottom iHeightMM * 100 * iHeightPels /
        SetRect: MetaRect
        ;M

\ Start recording of a Metafile
:M StartRecording: ( hRefDC -- f )
        GetGdiObjectHandle >r
        >r
        \ build description string
\         s" Win32Forth" pad place
\         pad count + dup 0 c! char + dup
\         MetaName count dup >r place r>
\         + char + 0 c!

\         pad 1+
        0 \ lpDescription
        Addrof: MetaRect
        0 \ lpstrFileName
        r> call CreateEnhMetaFile dup to hObject
        hObject 0<>
        ;M

\ Stop recording of a Metafile
:M StopRecording:  ( -- f )
        hObject ?dup
        if   call CloseEnhMetaFile dup SetHandle: Metafile 0<>
             0 to hObject
        else false
        then ;M

\ Load a metafile from a file
:M Load:        ( addr len -- f )
        StopRecording: self drop
        Load: Metafile ;M

\ Save the metafile in a file
:M Save:        ( addr len -- f )
        StopRecording: self drop
        Save: Metafile ;M

\ The DeleteEnhMetaFile function deletes an enhanced-format metafile
\ or an enhanced-format metafile handle.
:M Destroy:     ( -- )
        StopRecording: self drop
        Destroy: Metafile ;M

\ Play the metafile in a rectangle
:M Draw:        ( left top right bottom hDestDC -- )
        PlayInRect: Metafile ;M

\ Return the address of the metafile object used by this class
:M GetMetafile: ( -- MetafileObject )
        Metafile ;M
;class

module

--- NEW FILE: gdiFont.f ---
\ gdiFont.f
\
\ Written by Dirk Busch
\ Sonntag, Oktober 09 2005
\ Licence: Public Domain

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

needs gdiBase.f

internal
external

\ ----------------------------------------------------------------------
\ Font class
\ ----------------------------------------------------------------------
:Class GdiFont  <Super GdiObject

Record: LOGFONT
                int   lfHeight          \ width  in pixels, device specific
                int   lfWidth           \ height in pixels, device specific
                int   lfEscapement
                int   lfOrientation     \ in 10ths of a degree
                int   lfWeight
                byte  lfItalic          \ TRUE/FALSE
                byte  lfUnderline       \ TRUE/FALSE
                byte  lfStrikeOut       \ TRUE/FALSE
                byte  lfCharSet
                byte  lfOutPrecision
                byte  lfClipPrecision
                byte  lfQuality
                byte  lfPitchAndFamily
    LF_FACESIZE bytes lfFaceName        \ the font name
;RecordSize: sizeof(LOGFONT)

Record: &CHOOSEFONT
                int   lStructSize
                int   hwndOwner
                int   hDC
                int   lpLogFont
                int   iPointSize
                int   Flags
                int   rgbColors
                int   lCustData
                int   lpfnHook
                int   lpTemplateName
                int   hInstance
                int   lpszStyle
                short nFontType
                short ___MISSING_ALIGNMENT__
                int   nSizeMin
                int   nSizeMax
;RecordSize: sizeof(CHOOSEFONT)

:M ClassInit:   ( -- )
        ClassInit: super

        \ init LOGFONT record
        14                  to lfHeight
         9                  to lfWidth
         0                  to lfEscapement
         0                  to lfOrientation    \ in 10th degrees
        FW_DONTCARE         to lfWeight
        FALSE               to lfItalic
        FALSE               to lfUnderline
        FALSE               to lfStrikeOut
        ANSI_CHARSET        to lfCharSet
        OUT_TT_PRECIS       to lfOutPrecision
        CLIP_DEFAULT_PRECIS to lfClipPrecision
        PROOF_QUALITY       to lfQuality
        FIXED_PITCH 0x04 or
        FF_SWISS or         to lfPitchAndFamily \ font family
        lfFaceName LF_FACESIZE erase   \ clear font name
        s" Courier New" lfFaceName swap move \ move in default name

        \ init &CHOOSEFONT record
        sizeof(CHOOSEFONT) to lStructSize
        LOGFONT            to lpLogFont
        [ CF_SCREENFONTS CF_INITTOLOGFONTSTRUCT or ] literal to Flags
        null to hwndOwner
        null to hDC
        0    to iPointSize
        0    to rgbColors
        0    to lCustData
        null to lpfnHook
        null to lpTemplateName
        null to hInstance
        0    to lpszStyle
        0    to nFontType
        0    to nSizeMin
        0    to nSizeMax
        ;M

:M SetHeight:         ( n1 -- )  to lfHeight          ;M
:M SetWidth:          ( n1 -- )  to lfWidth           ;M
:M SetEscapement:     ( n1 -- )  to lfEscapement      ;M
:M SetOrientation:    ( n1 -- )  to lfOrientation     ;M   \ 10th/degree increments
:M SetWeight:         ( n1 -- )  to lfWeight          ;M
:M SetItalic:         ( f1 -- )  to lfItalic          ;M   \ TRUE/FALSE
:M SetUnderline:      ( f1 -- )  to lfUnderline       ;M   \ TRUE/FALSE
:M SetStrikeOut:      ( f1 -- )  to lfStrikeOut       ;M   \ TRUE/FALSE
:M SetCharSet:        ( n1 -- )  to lfCharSet         ;M
:M SetOutPrecision:   ( n1 -- )  to lfOutPrecision    ;M
:M SetClipPrecision:  ( n1 -- )  to lfClipPrecision   ;M
:M SetQuality:        ( n1 -- )  to lfQuality         ;M
:M SetPitchAndFamily: ( n1 -- )  to lfPitchAndFamily  ;M

:M SetFaceName: ( a1 n1 -- )
        lfFaceName LF_FACESIZE erase
        LF_FACESIZE 1- min lfFaceName swap move
        ;M

:M GetHeight:         ( -- n1 )  lfHeight          ;M
:M GetWidth:          ( -- n1 )  lfWidth           ;M
:M GetEscapement:     ( -- n1 )  lfEscapement      ;M
:M GetOrientation:    ( -- n1 )  lfOrientation     ;M   \ 10th/degree increments
:M GetWeight:         ( -- n1 )  lfWeight          ;M
:M GetItalic:         ( -- f1 )  lfItalic          ;M   \ TRUE/FALSE
:M GetUnderline:      ( -- f1 )  lfUnderline       ;M   \ TRUE/FALSE
:M GetStrikeOut:      ( -- f1 )  lfStrikeOut       ;M   \ TRUE/FALSE
:M GetCharSet:        ( -- n1 )  lfCharSet         ;M
:M GetOutPrecision:   ( -- n1 )  lfOutPrecision    ;M
:M GetClipPrecision:  ( -- n1 )  lfClipPrecision   ;M
:M GetQuality:        ( -- n1 )  lfQuality         ;M
:M GetPitchAndFamily: ( -- n1 )  lfPitchAndFamily  ;M
:M GetLogfont:        ( -- n1 )  LOGFONT           ;M

:M GetFaceName: ( -- a1 n1 )
        lfFaceName LF_FACESIZE 2dup 0 scan nip - ;M

:M Create:      ( -- f )
        LOGFONT Call CreateFontIndirect SetHandle: super
        Valid?: super ;M

: Choose        ( hWnd -- f )
        to hwndOwner
        &CHOOSEFONT call ChooseFont
        if   Create: self
        else false
        then ;

\ let the user choose a Screen font
:M Choose:      ( hWnd -- f )
        [ CF_SCREENFONTS CF_INITTOLOGFONTSTRUCT or ] literal to Flags
        Choose ;M

\ let the user choose a Printer font for the PrinterDC hDC
:M ChoosePrinter: ( hWnd hDC -- f )
        GetGdiObjectHandle to hDC
        [ CF_PRINTERFONTS CF_INITTOLOGFONTSTRUCT or ] literal to Flags
        Choose ;M
;Class

module

[Win32forth-cvs] win32forth fkernel.exe,1.27,1.28

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13139

Modified Files:
	fkernel.exe 
Log Message:
- Added my GDI class library to the CVS
- WinDC and Font classes rewritten to use the GDI class library
- Added some demo's whitch are using the GDI class library

Index: fkernel.exe
===================================================================
RCS file: /cvsroot/win32forth/win32forth/fkernel.exe,v
retrieving revision 1.27
retrieving revision 1.28
diff -C2 -d -r1.27 -r1.28
Binary files /tmp/cvsH7sne0 and /tmp/cvsboAt5f differ

[Win32forth-cvs] win32forth/src/gdi - New directory

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src/gdi
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12376/gdi

Log Message:
Directory /cvsroot/win32forth/win32forth/src/gdi added to the repository

[Win32forth-cvs] win32forth/demos/GdiDemo - New directory

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/demos/GdiDemo
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12074/GdiDemo

Log Message:
Directory /cvsroot/win32forth/win32forth/demos/GdiDemo added to the repository

[Win32forth-cvs] win32forth/src/lib HtmlDisplayWindow.f,1.2,1.3

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9459/src/lib

Modified Files:
	HtmlDisplayWindow.f 
Log Message:
Deprecated SetString: removed from HtmlDisplayWindow class

Index: HtmlDisplayWindow.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/HtmlDisplayWindow.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** HtmlDisplayWindow.f	15 Sep 2005 16:36:09 -0000	1.2
--- HtmlDisplayWindow.f	1 Nov 2005 12:05:41 -0000	1.3
***************
*** 246,251 ****
  		;M
  
! :M SetString:   ( zUrl -- )
! 		drop ;M DEPRECATED
  
  :M SetURL:      ( zUrl -- )
--- 246,251 ----
  		;M
  
! \ :M SetString:   ( zUrl -- )
! \ 		drop ;M DEPRECATED
  
  :M SetURL:      ( zUrl -- )

[Win32forth-cvs] win32forth/src CHILDWND.F,1.1,1.2

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8991/src

Modified Files:
	CHILDWND.F 
Log Message:
removed Parent  IVAR from Child-Window class, since it's defined in the window class.

Index: CHILDWND.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/CHILDWND.F,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** CHILDWND.F	21 Dec 2004 00:19:07 -0000	1.1
--- CHILDWND.F	1 Nov 2005 12:04:03 -0000	1.2
***************
*** 11,15 ****
  :CLASS Child-Window     <Super Window
  
! int Parent      \ window object that is the parent
  int id          \ id for this child window
  
--- 11,15 ----
  :CLASS Child-Window     <Super Window
  
! \ int Parent      \ window object that is the parent
  int id          \ id for this child window
  

[Win32forth-cvs] win32forth/apps/Player4 Catalog.f,1.17,1.18

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv19698/apps/Player4

Modified Files:
	Catalog.f 
Log Message:
Jos: Removed the debug command

Index: Catalog.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Catalog.f,v
retrieving revision 1.17
retrieving revision 1.18
diff -C2 -d -r1.17 -r1.18
*** Catalog.f	30 Oct 2005 18:58:14 -0000	1.17
--- Catalog.f	31 Oct 2005 18:05:17 -0000	1.18
***************
*** 304,307 ****
--- 304,316 ----
  >RecordDef FileSize    1 cells    key: FileSizeKey     FileSizeKey     bin-sort
  
+ : &FlexKeyLen ( - &FlexKeyLen ) FlexKey &key-len ;
+ : MinFlexKey! ( n - )           min FlexKey !    ;
+ 
+ /artist /album + /Title +  constant  /Record
+ 
+ : by_record  ( - FlexKey )
+     /Record &FlexKeyLen ! FlexKey @ >RecordDef Artist MinFlexKey! FlexKey
+   ;
+ 
  : By_FileName           ( - by )  by[   FileNameKey     ]by ;
  : By_Random             ( - by )  by[   RandomKey       ]by ;
***************
*** 316,320 ****
                  r@ RecordDef DriveType  c@ .
                  r@ RecordDef MediaLabel r@ RecordDef Cnt_MediaLabel c@ type-space
!                 r@ RecordDef File_name r@   Cnt_File_name c@   type-space
                  cr 3 spaces
                  r@ RecordDef Artist r@   Cnt_Artist c@   type-space
--- 325,329 ----
                  r@ RecordDef DriveType  c@ .
                  r@ RecordDef MediaLabel r@ RecordDef Cnt_MediaLabel c@ type-space
!                 r@ RecordDef File_name r@  Cnt_File_name c@   type-space
                  cr 3 spaces
                  r@ RecordDef Artist r@   Cnt_Artist c@   type-space
***************
*** 343,349 ****
   ;
  
- : &FlexKeyLen ( - &FlexKeyLen ) FlexKey &key-len ;
- : MinFlexKey! ( n - )           min FlexKey !    ;
- 
  : sort_by_filename      ( - )    by_FileName    sort-database ;
  : sort_by_leastPlayed   ( - )    by_leastPlayed sort-database ;
--- 352,355 ----
***************
*** 357,364 ****
          r@ s_#Random-  c@   of By_Random sort-database      endof
  
!         r@ s_Random_impopular-  c@  of by[ RandomKey leastPlayedKey Ascending ]by
!                                sort-database                endof
!         r@ s_Random_popular-    c@  of by[ RandomKey leastPlayedKey Descending ]by
!                                sort-database                endof
  
          r@ s_#Played-  c@   of sort_by_leastPlayed          endof
--- 363,372 ----
          r@ s_#Random-  c@   of By_Random sort-database      endof
  
!         r@ s_Random_impopular-  c@  of by[  by_record RandomKey
!                                        leastPlayedKey Ascending  ]by
!                                        sort-database                endof
!         r@ s_Random_popular-    c@  of by[  by_record RandomKey
!                                        leastPlayedKey Descending ]by
!                                        sort-database                endof
  
          r@ s_#Played-  c@   of sort_by_leastPlayed          endof
***************
*** 367,379 ****
          sizeof  RecordDef FlexKey !      0 &FlexKeyLen !
          r@ s_Drivetype- c@
!                 if      [ /Drivetype /MediaLabel +  /artist + /Title + ] literal &FlexKeyLen !
                           FlexKey @ >RecordDef DriveType MinFlexKey!
                  then
          r@ s_Label- c@
!                 if      [ /MediaLabel /artist + /Title + ] literal &FlexKeyLen !
                          FlexKey @ >RecordDef MediaLabel MinFlexKey!
                  then
          r@ s_Artist_Title- c@
!                 if      [ /artist /Title + ] literal &FlexKeyLen !
                          FlexKey @ >RecordDef Artist MinFlexKey!
                  then
--- 375,387 ----
          sizeof  RecordDef FlexKey !      0 &FlexKeyLen !
          r@ s_Drivetype- c@
!                 if      [ /Drivetype /MediaLabel +  /Record + ] literal &FlexKeyLen !
                           FlexKey @ >RecordDef DriveType MinFlexKey!
                  then
          r@ s_Label- c@
!                 if      [ /MediaLabel /Record + ] literal &FlexKeyLen !
                          FlexKey @ >RecordDef MediaLabel MinFlexKey!
                  then
          r@ s_Artist_Title- c@
!                 if      [ /Record ] literal &FlexKeyLen !
                          FlexKey @ >RecordDef Artist MinFlexKey!
                  then
***************
*** 443,448 ****
   ;
  
- debug (add-file)
- 
  external
  
--- 451,454 ----

[Win32forth-cvs] win32forth/apps/Player4 Catalog.f,1.16,1.17 Mediatree.f,1.20,1.21 View.f,1.4,1.5

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26533/apps/Player4

Modified Files:
	Catalog.f Mediatree.f View.f 
Log Message:
Jos: Prepared the catalog for Asx-play-lists and changed the view, so that it will also show the album from which the record was taken.
The album is extracted from the full file-name.
You will have to remove your old *.dat files for the catalog to use this version. (last time I hope)

Index: Mediatree.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Mediatree.f,v
retrieving revision 1.20
retrieving revision 1.21
diff -C2 -d -r1.20 -r1.21
*** Mediatree.f	26 Oct 2005 15:26:54 -0000	1.20
--- Mediatree.f	30 Oct 2005 18:58:14 -0000	1.21
***************
*** 51,54 ****
--- 51,56 ----
               else   dup RecordDef Artist    over Cnt_Artist     c@ +InlineRecord
                      s" --" +InlineRecord
+                     dup RecordDef Album    over Cnt_Album       c@ +InlineRecord
+                     s" --" +InlineRecord
                      dup RecordDef Title     swap Cnt_Title      c@
               then

Index: Catalog.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Catalog.f,v
retrieving revision 1.16
retrieving revision 1.17
diff -C2 -d -r1.16 -r1.17
*** Catalog.f	26 Oct 2005 15:19:15 -0000	1.16
--- Catalog.f	30 Oct 2005 18:58:14 -0000	1.17
***************
*** 43,48 ****
                  BYTE                    l_#Played-
                  BYTE                    l_Filename-
!                 BYTE                    l_Artist_and_title-
! 
  ;struct
  
--- 43,47 ----
                  BYTE                    l_#Played-
                  BYTE                    l_Filename-
!                 BYTE                    l_Record-
  ;struct
  
***************
*** 58,70 ****
   ;
  
! \ Record discription of the catalog. October 14th, 2005.
! \ This model assumes that the filename is the title of an album and
! \ that it is placed in a directory named after the artist.
  
  255 constant    /file_name
   32 constant    /MediaLabel
!  80 constant    /artist
! 120 constant    /Title
    1 constant    /Drivetype
  
  :struct RecordDef \ catalog
--- 57,73 ----
   ;
  
! \ Record discription of the catalog. October 30th, 2005.
! \ This model assumes that the filename is the title and
! \ that it placed in a directory named after the album
! \ The directory the album is is placed in a directory named after artist.
  
  255 constant    /file_name
   32 constant    /MediaLabel
!  90 constant    /artist
!  80 constant    /album
!  85 constant    /Title
    1 constant    /Drivetype
+  90 constant    /Composer
+  15 constant    /Genre
  
  :struct RecordDef \ catalog
***************
*** 72,76 ****
                  BYTE                    Excluded-
                  BYTE                    Played-
!                 DWORD                   FileSize 
  Offset Deleted-thread
                  DWORD                   RandomLevel
--- 75,79 ----
                  BYTE                    Excluded-
                  BYTE                    Played-
!                 DWORD                   FileSize
  Offset Deleted-thread
                  DWORD                   RandomLevel
***************
*** 78,92 ****
                  /Drivetype      Field:  DriveType
                  /MediaLabel     Field:  MediaLabel
                  /artist         Field:  Artist   \ Extracted from the filename
                  /Title          Field:  Title    \ Extracted from the filename
                  /file_name      Field:  File_name
                  BYTE                    Cnt_File_name
                  BYTE                    Cnt_MediaLabel
                  BYTE                    Cnt_Artist
                  BYTE                    Cnt_Title
!                 DWORD                   Not_used1
!                 DWORD                   Not_used2
!                 DWORD                   Not_used3
!                 DWORD                   Not_used4
    ;struct
  
--- 81,101 ----
                  /Drivetype      Field:  DriveType
                  /MediaLabel     Field:  MediaLabel
+                 /Genre          Field:  Genre
                  /artist         Field:  Artist   \ Extracted from the filename
+                 /Album          Field:  Album    \ Extracted from the filename
                  /Title          Field:  Title    \ Extracted from the filename
                  /file_name      Field:  File_name
+                 /Composer       Field:  Composer
                  BYTE                    Cnt_File_name
                  BYTE                    Cnt_MediaLabel
                  BYTE                    Cnt_Artist
+                 BYTE                    Cnt_Album
                  BYTE                    Cnt_Title
!                 BYTE                    UserRating
!                 BYTE                    PlayPeriod
!                 DWORD                   YearReleased
!                 DWORD                   Bitrate
!                 DWORD                   NotUsed1
!                 DWORD                   NotUsed2
    ;struct
  
***************
*** 310,313 ****
--- 319,323 ----
                  cr 3 spaces
                  r@ RecordDef Artist r@   Cnt_Artist c@   type-space
+                 r@ RecordDef Album r@    Cnt_Album  c@   type-space
                  r@ RecordDef Title  r@   Cnt_Title  c@   type-space
  
***************
*** 411,417 ****
                         struct, InlineRecord RecordDef Cnt_Title    c!
                         struct, InlineRecord RecordDef Title swap cmove \ move Title
!                        swap 1- dup rot ascii \ -scan drop 2dup - swap 1+ over
!                        struct, InlineRecord RecordDef Cnt_Artist    c!
!                        struct, InlineRecord RecordDef Artist  rot   cmove
                         drop
                         struct, InlineRecord RecordDef File_name        r@ cmove
--- 421,433 ----
                         struct, InlineRecord RecordDef Cnt_Title    c!
                         struct, InlineRecord RecordDef Title swap cmove \ move Title
! 
!                        >r 1- dup r> ascii \ -scan >r 2dup - >r 1+
!                        r@ struct, InlineRecord RecordDef Cnt_Album  c!
!                        struct, InlineRecord RecordDef Album  r@  cmove
! 
!                        r> - 1- dup r>  ascii \ -scan drop 2dup - swap 1+ over
!                        struct, InlineRecord RecordDef Cnt_Artist  c!
!                        struct, InlineRecord RecordDef Artist rot  cmove
! 
                         drop
                         struct, InlineRecord RecordDef File_name        r@ cmove
***************
*** 427,430 ****
--- 443,448 ----
   ;
  
+ debug (add-file)
+ 
  external
  

Index: View.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/View.f,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** View.f	27 Oct 2005 21:26:27 -0000	1.4
--- View.f	30 Oct 2005 18:58:14 -0000	1.5
***************
*** 19,23 ****
  CheckBox lbl_Label
  CheckBox R_Filename
! CheckBox R_Artist_and_title
  PushButton Button1
  PushButton Button2
--- 19,23 ----
  CheckBox lbl_Label
  CheckBox R_Filename
! CheckBox R_Record
  PushButton Button1
  PushButton Button2
***************
*** 128,135 ****
                  s" Filename" SetText: R_Filename
  
!                 self Start: R_Artist_and_title
!                 60 270 104 16 Move: R_Artist_and_title
!                 Handle: Winfont SetFont: R_Artist_and_title
!                 s" Artist_and_title" SetText: R_Artist_and_title
  
                  IDOK SetID: Button1
--- 128,135 ----
                  s" Filename" SetText: R_Filename
  
!                 self Start: R_Record
!                 60 270 104 16 Move: R_Record
!                 Handle: Winfont SetFont: R_Record
!                 s" Record" SetText: R_Record
  
                  IDOK SetID: Button1
***************
*** 218,222 ****
                          l_Filename-         c@
                                 if   CheckButton: R_Filename
!                                else CheckButton: R_Artist_and_title
                                 then
                  ;M
--- 218,222 ----
                          l_Filename-         c@
                                 if   CheckButton: R_Filename
!                                else CheckButton: R_Record
                                 then
                  ;M
***************
*** 240,244 ****
     IsButtonChecked?: lbl_#Played        over l_#Played-      c!
     IsButtonChecked?: R_Filename         over l_Filename-     c!
!    IsButtonChecked?: R_Artist_and_title swap l_Artist_and_title- c!
   ;
  
--- 240,244 ----
     IsButtonChecked?: lbl_#Played        over l_#Played-      c!
     IsButtonChecked?: R_Filename         over l_Filename-     c!
!    IsButtonChecked?: R_Record           swap l_Record-       c!
   ;
  

[Win32forth-cvs] win32forth/src/lib ExtStruct.f,1.3,1.4

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11537/src/lib

Modified Files:
	ExtStruct.f 
Log Message:
Alias for COLORREF's added

Index: ExtStruct.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/lib/ExtStruct.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** ExtStruct.f	4 Jun 2005 08:51:20 -0000	1.3
--- ExtStruct.f	29 Oct 2005 09:44:38 -0000	1.4
***************
*** 68,74 ****
  
  \ Not standard in C
! 
! ' dword alias HWND  \ 4 bytes
! ' dword alias HICON \ 4 bytes
  
  [DEFINED] b/float [IF]
--- 68,74 ----
  
  \ Not standard in C
! ' dword alias HWND     \ 4 bytes
! ' dword alias HICON    \ 4 bytes
! ' dword alias COLORREF \ 4 bytes (added Samstag, Oktober 22 2005 dbu)
  
  [DEFINED] b/float [IF]
***************
*** 85,89 ****
          _struct offset ;        \ run-time: ( offset - offset+dword )
  
! 0 value current-voc 
  
  \ Close a struct definiton.
--- 85,89 ----
          _struct offset ;        \ run-time: ( offset - offset+dword )
  
! 0 value current-voc
  
  \ Close a struct definiton.
***************
*** 93,97 ****
          previous
          current-voc set-current
!         -1 +to olddepth 
          ;
  
--- 93,97 ----
          previous
          current-voc set-current
!         -1 +to olddepth
          ;
  
***************
*** 142,146 ****
                if   interpret \ Compile the offset+ part inside a definition
                     previous  \ and restore the order
!               then                     
          ;
  
--- 142,146 ----
                if   interpret \ Compile the offset+ part inside a definition
                     previous  \ and restore the order
!               then
          ;
  
***************
*** 152,156 ****
  : :struct       ( -<name-struct>- -- ptr-size )
          /parse-word count ( addr len )
!         
          \ create the vocabulary for the struct in the 'structs' vocabulary
          2dup create-struct-voc ( addr len wid )
--- 152,156 ----
  : :struct       ( -<name-struct>- -- ptr-size )
          /parse-word count ( addr len )
! 
          \ create the vocabulary for the struct in the 'structs' vocabulary
          2dup create-struct-voc ( addr len wid )
***************
*** 300,302 ****
  
  decimal
- 

[Win32forth-cvs] win32forth/src Class.f,1.6,1.7

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11334/src

Modified Files:
	Class.f 
Log Message:
Methods: Addr: Width: and Height: added to class rectangle.

Index: Class.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Class.f,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** Class.f	17 Oct 2005 08:56:21 -0000	1.6
--- Class.f	29 Oct 2005 09:42:31 -0000	1.7
***************
*** 1178,1181 ****
--- 1178,1182 ----
  
  :M AddrOf:      ( -- n1 )       AddrOf ;M
+ :M Addr:        ( -- n1 )       AddrOf ;M
  :M Left:        ( -- n1 )       Left   ;M
  :M Top:         ( -- n1 )       Top    ;M
***************
*** 1183,1186 ****
--- 1184,1190 ----
  :M Bottom:      ( -- n1 )       Bottom ;M
  
+ :M Width:       ( -- n1 )       right left - ;M
+ :M Height:      ( -- n1 )       bottom top - ;M
+ 
  :M .Rect:       ( -- )
                  cr ." Rect: " Left . Top . Right . Bottom .
***************
*** 1238,1240 ****
  
  only forth also definitions
- 

[Win32forth-cvs] win32forth/src numconv.f,1.5,1.6

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11052/src

Modified Files:
	numconv.f 
Log Message:
fixed a smal bug (typo)

Index: numconv.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/numconv.f,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** numconv.f	27 Aug 2005 09:02:10 -0000	1.5
--- numconv.f	29 Oct 2005 09:39:57 -0000	1.6
***************
*** 21,25 ****
  \ has been detected in each routine separately.
  
! \ Floating point numbers are returned in the floating point stack; there is 
  \ no return value, and the variable FLOAT? is set. See FLOAT.F for details;
  \ the code is in that file, not here. NOTE - even floating point routines must
--- 21,25 ----
  \ has been detected in each routine separately.
  
! \ Floating point numbers are returned in the floating point stack; there is
  \ no return value, and the variable FLOAT? is set. See FLOAT.F for details;
  \ the code is in that file, not here. NOTE - even floating point routines must
***************
*** 176,180 ****
  3 proc wcFindWin32Constant
  winproc-last @ constant WinConPtr      \ for **WORDS.F**
! 3 proc wsEnumWin32Constants
  winproc-last @ constant WinEnumPtr      \ for **WORDS.F**
  
--- 176,180 ----
  3 proc wcFindWin32Constant
  winproc-last @ constant WinConPtr      \ for **WORDS.F**
! 3 proc wcEnumWin32Constants
  winproc-last @ constant WinEnumPtr      \ for **WORDS.F**
  

[Win32forth-cvs] win32forth/apps/Player4 View.f,1.3,1.4

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13684/apps/Player4

Modified Files:
	View.f 
Log Message:
Jos: Resized 2 labels

Index: View.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/View.f,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** View.f	26 Oct 2005 15:19:15 -0000	1.3
--- View.f	27 Oct 2005 21:26:27 -0000	1.4
***************
*** 191,200 ****
  
                  self Start: lbl_Random_popular
!                 60 110 125 16 Move: lbl_Random_popular
                  Handle: Winfont SetFont: lbl_Random_popular
                  s" Random popular" SetText: lbl_Random_popular
  
                  self Start: lbl_Random_impopular
!                 60 130 130 16 Move: lbl_Random_impopular
                  Handle: Winfont SetFont: lbl_Random_impopular
                  s" Random impopular" SetText: lbl_Random_impopular
--- 191,200 ----
  
                  self Start: lbl_Random_popular
!                 60 110 115 16 Move: lbl_Random_popular
                  Handle: Winfont SetFont: lbl_Random_popular
                  s" Random popular" SetText: lbl_Random_popular
  
                  self Start: lbl_Random_impopular
!                 60 130 115 16 Move: lbl_Random_impopular
                  Handle: Winfont SetFont: lbl_Random_impopular
                  s" Random impopular" SetText: lbl_Random_impopular

[Win32forth-cvs] win32forth/apps/Player4 shell_r.f,1.2,NONE

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16514/apps/Player4

Removed Files:
	shell_r.f 
Log Message:
Removed the old version

--- shell_r.f DELETED ---

[Win32forth-cvs] win32forth/apps/Player4 Mediatree.f,1.19,1.20

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14758/apps/Player4

Modified Files:
	Mediatree.f 
Log Message:
Jos: adapted for the new improoved shellsort.

Index: Mediatree.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Mediatree.f,v
retrieving revision 1.19
retrieving revision 1.20
diff -C2 -d -r1.19 -r1.20
*** Mediatree.f	26 Oct 2005 15:20:21 -0000	1.19
--- Mediatree.f	26 Oct 2005 15:26:54 -0000	1.20
***************
*** 120,124 ****
          0 0 -1 hDrop  Call DragQueryFile  ?dup
             if  datfile$ count file-exist? check-config
!                MAXCOUNTED drop$ 0 hDrop Call DragQueryFile
                 drop$ swap GetLabel
                 OpenAppendDatabase to wHndl
--- 120,124 ----
          0 0 -1 hDrop  Call DragQueryFile  ?dup
             if  datfile$ count file-exist? check-config
!                MAXCOUNTED drop$ 0 hDrop Call DragQueryFile 
                 drop$ swap GetLabel
                 OpenAppendDatabase to wHndl
***************
*** 194,196 ****
  \s
  
! 

[Win32forth-cvs] win32forth/apps/Player4 Mediatree.f,1.18,1.19

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13467/apps/Player4

Modified Files:
	Mediatree.f 
Log Message:
Jos: adapted for the new shellsort

Index: Mediatree.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Mediatree.f,v
retrieving revision 1.18
retrieving revision 1.19
diff -C2 -d -r1.18 -r1.19
*** Mediatree.f	20 Oct 2005 17:10:49 -0000	1.18
--- Mediatree.f	26 Oct 2005 15:20:21 -0000	1.19
***************
*** 3,7 ****
  needs number.f
  needs w_search.f
! needs shell_r.f
  needs catalog.f
  needs TreeView.F
--- 3,7 ----
  needs number.f
  needs w_search.f
! needs mshell_r.f
  needs catalog.f
  needs TreeView.F
***************
*** 156,160 ****
  :M Refresh:     ( -- )
          MciDebug?
!         if      cr timer-reset
          then
          wait-cursor
--- 156,160 ----
  :M Refresh:     ( -- )
          MciDebug?
!         if      cr ." Fill-time: " timer-reset
          then
          wait-cursor

[Win32forth-cvs] win32forth/apps/Player4 Catalog.f,1.15,1.16 PLAYER4.F,1.27,1.28 Pl_Version.f,1.14,1.15 View.f,1.2,1.3 view.ff,1.1,1.2

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13158/apps/Player4

Modified Files:
	Catalog.f PLAYER4.F Pl_Version.f View.f view.ff 
Log Message:
Jos: Added more views and adapted the sources for the improoved shellsort.

Index: view.ff
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/view.ff,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
Binary files /tmp/cvsz74kPr and /tmp/cvsGHerye differ

Index: PLAYER4.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/PLAYER4.F,v
retrieving revision 1.27
retrieving revision 1.28
diff -C2 -d -r1.27 -r1.28
*** PLAYER4.F	19 Oct 2005 19:37:20 -0000	1.27
--- PLAYER4.F	26 Oct 2005 15:19:15 -0000	1.28
***************
*** 44,48 ****
  needs number.f
  needs w_search.f
! needs shell_r.f
  needs catalog.f
  needs TrayWindow.f
--- 44,48 ----
  needs number.f
  needs w_search.f
! needs mshell_r.f
  needs catalog.f
  needs TrayWindow.f

Index: Catalog.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Catalog.f,v
retrieving revision 1.15
retrieving revision 1.16
diff -C2 -d -r1.15 -r1.16
*** Catalog.f	19 Oct 2005 19:37:20 -0000	1.15
--- Catalog.f	26 Oct 2005 15:19:15 -0000	1.16
***************
*** 5,9 ****
  needs Pl_Toolset.f
  needs w_search.f
! needs shell_r.f
  needs sub_dirs.f
  
--- 5,9 ----
  needs Pl_Toolset.f
  needs w_search.f
! needs mshell_r.f
  needs sub_dirs.f
  
***************
*** 31,34 ****
--- 31,36 ----
                  BYTE                    s_filesize-
                  BYTE                    s_#Random-
+                 BYTE                    s_Random_popular-
+                 BYTE                    s_Random_impopular-
                  BYTE                    s_#Played-
                  BYTE                    s_Filename-
***************
*** 64,67 ****
--- 66,70 ----
   80 constant    /artist
  120 constant    /Title
+   1 constant    /Drivetype
  
  :struct RecordDef \ catalog
***************
*** 73,77 ****
                  DWORD                   RandomLevel
                  DWORD                   #played
!                 BYTE                    DriveType
                  /MediaLabel     Field:  MediaLabel
                  /artist         Field:  Artist   \ Extracted from the filename
--- 76,80 ----
                  DWORD                   RandomLevel
                  DWORD                   #played
!                 /Drivetype      Field:  DriveType
                  /MediaLabel     Field:  MediaLabel
                  /artist         Field:  Artist   \ Extracted from the filename
***************
*** 94,98 ****
  
  sizeof  RecordDef dup   to record-size   mkstruct: InlineRecord
! 
  : file-exist?   ( adr len -- true-if-file-exist )  file-status nip 0= ;
  : file-size>s   ( fileid -- len )       file-size drop d>s  ;
--- 97,102 ----
  
  sizeof  RecordDef dup   to record-size   mkstruct: InlineRecord
!    
! : >RecordDef     ( - rel )               s" 0 RecordDef " EVALUATE ; IMMEDIATE
  : file-exist?   ( adr len -- true-if-file-exist )  file-status nip 0= ;
  : file-size>s   ( fileid -- len )       file-size drop d>s  ;
***************
*** 162,168 ****
  in-application
  
! \ Define key-len  and key-start before using sort-database
! : sort-database ( - ) 0 n>aptr  database-mhndl #records-in-database  shell-rel ;
! : sort-database-bin ( - ) 0 n>aptr database-mhndl #records-in-database shell-rel-c ;
  
  : rebuild-index-hdrs  ( - ) \ database must mapped
--- 166,180 ----
  in-application
  
! \ Define a key before using sort-database
! : sort-database ( key1..keyx #keys - )
!     0 n>aptr  database-mhndl #records-in-database
!       MciDebug?
!         if      cr ." Sort-time:" timer-reset
!         then
!      mshell-rel
!      MciDebug?
!         if      .elapsed
!         then
!   ;
  
  : rebuild-index-hdrs  ( - ) \ database must mapped
***************
*** 276,282 ****
   ;
  
! : by_FileName    ( - ) /file_name to key-len 0 RecordDef File_name to key-start ;
! : by_FileSize    ( - ) 1 cells    to key-len 0 RecordDef FileSize  to key-start ;
! : by_leastPlayed ( - ) 1 cells    to key-len 0 RecordDef #played   to key-start ;
  
  : not-deleted? ( rec-adr - flag )   s" RecordDef deleted- c@ 0= " EVALUATE ; IMMEDIATE
--- 288,302 ----
   ;
  
! 
! >RecordDef File_name   /file_name key: FileNameKey
! >RecordDef MediaLabel  255        key: FlexKey
! >RecordDef RandomLevel 1 cells    key: RandomKey       RandomKey       bin-sort
! >RecordDef #played     1 cells    key: leastPlayedKey  leastPlayedKey  bin-sort
! >RecordDef FileSize    1 cells    key: FileSizeKey     FileSizeKey     bin-sort
! 
! : By_FileName           ( - by )  by[   FileNameKey     ]by ;
! : By_Random             ( - by )  by[   RandomKey       ]by ;
! : by_leastPlayed        ( - by )  by[   leastPlayedKey Ascending ]by ;
! : by_FileSize           ( - by )  by[   FileSizeKey     ]by ;
  
  : not-deleted? ( rec-adr - flag )   s" RecordDef deleted- c@ 0= " EVALUATE ; IMMEDIATE
***************
*** 309,386 ****
  : list-database ( - )   map-database  list-records unmap-database ;
  
! : change-randomlevel    ( level n - )  n>record over random swap RecordDef RandomLevel  ! ;
! : sort_by_filename      ( - )    by_FileName    sort-database     ;
! : sort_by_filesize      ( - )    by_FileSize    sort-database-bin ;
! : sort_by_leastPlayed   ( - )    by_leastPlayed sort-database-bin ;
! : sort_by_size          ( - )    by_FileSize    sort-database-bin ;
  
  : SortByFlags ( - )
!    vadr-config
!      dup>r s_Filename- c@
!         if sort_by_filename  then
!      0 to key-len       maxstring to key-start
!      r@ s_#Random- c@
!         if      1 cells to key-len      0 RecordDef RandomLevel to key-start
!         then
!      r@ s_#Played- c@
!         if      key-len 1 cells +  to key-len
!                 key-start 0 RecordDef #played  min to key-start
!         then
!      r@ s_Drivetype- c@
!         if      key-len 1+ to key-len
!                 key-start 0 RecordDef DriveType min to key-start
!         then
!      r@ s_Label-  c@
!         if      key-len /MediaLabel + to key-len
!                 key-start 0 RecordDef MediaLabel min to key-start
!         then
!      r@ s_Artist_Title- c@
!         if      key-len [ /artist /Title + ] literal + to key-len
!                 key-start 0 RecordDef Artist min to key-start
!         then
!     key-len 0>
!         if      sort-database
!         then
!      r> s_filesize- c@
!         if     sort_by_size
!         then
!  ;
  
! (( : 0SortByFlags ( - ) \ Not yet useable
!    vadr-config
!      dup>r s_Filename- c@
!         if sort_by_filename  then
  
!      r@ s_Artist_Title- c@
!         if      [ /artist /Title + ] literal  to key-len
!                 0 RecordDef Artist to key-start
!                 sort-database
!         then
  
!      r@ s_#Played- c@
!         if      sort_by_leastPlayed
!         then
!      r@ s_#Random- c@
!         if      1 cells to key-len      0 RecordDef RandomLevel to key-start
!                 sort-database-bin
!         then
!      r@ s_filesize- c@
!         if     sort_by_size
!         then
!      r@ s_Label-  c@
!         if      /MediaLabel to key-len  0 RecordDef MediaLabel  to key-start
!                 sort-database
!         then
!      r> s_Drivetype- c@
!         if      1 to key-len            0 RecordDef DriveType   to key-start
!                 sort-database-bin
!         then
!  ; ))
  
  : sort_by_RandomLevel ( - )
!         1 cells                  to key-len
!         0 RecordDef RandomLevel  to key-start  sort-database-bin
!         0 RecordDef #played      to key-start  sort-database-bin
! \        0 RecordDef Deleted-     to key-start  sort-database-bin
  
    ;
--- 329,385 ----
  : list-database ( - )   map-database  list-records unmap-database ;
  
! : change-randomlevel  ( level n - )
!    n>record over random swap RecordDef RandomLevel  !
!  ;
! 
! : &FlexKeyLen ( - &FlexKeyLen ) FlexKey &key-len ;
! : MinFlexKey! ( n - )           min FlexKey !    ;
! 
! : sort_by_filename      ( - )    by_FileName    sort-database ;
! : sort_by_leastPlayed   ( - )    by_leastPlayed sort-database ;
! : sort_by_size          ( - )    by_FileSize    sort-database ;
! 
  
  : SortByFlags ( - )
!    vadr-config >r 1
!     case
!         r@ s_Filename- c@   of sort_by_filename             endof
!         r@ s_#Random-  c@   of By_Random sort-database      endof
  
!         r@ s_Random_impopular-  c@  of by[ RandomKey leastPlayedKey Ascending ]by
!                                sort-database                endof
!         r@ s_Random_popular-    c@  of by[ RandomKey leastPlayedKey Descending ]by
!                                sort-database                endof
  
!         r@ s_#Played-  c@   of sort_by_leastPlayed          endof
!         r@ s_filesize- c@   of sort_by_size                 endof
  
!         sizeof  RecordDef FlexKey !      0 &FlexKeyLen !
!         r@ s_Drivetype- c@
!                 if      [ /Drivetype /MediaLabel +  /artist + /Title + ] literal &FlexKeyLen !
!                          FlexKey @ >RecordDef DriveType MinFlexKey!
!                 then
!         r@ s_Label- c@
!                 if      [ /MediaLabel /artist + /Title + ] literal &FlexKeyLen !
!                         FlexKey @ >RecordDef MediaLabel MinFlexKey!
!                 then
!         r@ s_Artist_Title- c@
!                 if      [ /artist /Title + ] literal &FlexKeyLen !
!                         FlexKey @ >RecordDef Artist MinFlexKey!
!                 then
!         FlexKey &key-len @ 0>
!                 if      by[ FlexKey ]by sort-database
!                 then
! 
!     endcase
!    r>drop
!  ;
  
  : sort_by_RandomLevel ( - )
!         By_Random sort-database
!       \  1 cells                  to key-len
!       \  >RecordDef RandomLevel  to key-start  sort-database-bin
!       \  >RecordDef #played      to key-start  sort-database-bin
! \     \   >RecordDef Deleted-    to key-start  sort-database-bin
  
    ;

Index: View.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/View.f,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** View.f	19 Oct 2005 19:37:20 -0000	1.2
--- View.f	26 Oct 2005 15:19:15 -0000	1.3
***************
*** 24,27 ****
--- 24,29 ----
  RadioButton s_filesize
  RadioButton s_#Random
+ RadioButton s_Random_popular
+ RadioButton s_Random_impopular
  RadioButton s_#played
  RadioButton s_DriveType
***************
*** 29,32 ****
--- 31,36 ----
  RadioButton s_Filename
  RadioButton s_Artist_Title
+ Label lbl_Random_popular
+ Label lbl_Random_impopular
  
  :M ClassInit:   ( -- )
***************
*** 53,57 ****
  
  :M StartSize:   ( -- width height )
!                 197 290
                  ;M
  
--- 57,61 ----
  
  :M StartSize:   ( -- width height )
!                 213 351
                  ;M
  
***************
*** 75,89 ****
  
                  self Start: Group1
!                 20 10 159 242 Move: Group1
                  Handle: Winfont SetFont: Group1
                  s" Sort/Group" SetText: Group1
  
                  self Start: Group2
!                 50 30 118 145 Move: Group2
                  Handle: Winfont SetFont: Group2
                  s" Optional" SetText: Group2
  
                  self Start: Group3
!                 50 180 118 63 Move: Group3
                  Handle: Winfont SetFont: Group3
                  s" Name" SetText: Group3
--- 79,93 ----
  
                  self Start: Group1
!                 20 10 179 301 Move: Group1
                  Handle: Winfont SetFont: Group1
                  s" Sort/Group" SetText: Group1
  
                  self Start: Group2
!                 50 30 135 187 Move: Group2
                  Handle: Winfont SetFont: Group2
                  s" Optional" SetText: Group2
  
                  self Start: Group3
!                 50 230 134 65 Move: Group3
                  Handle: Winfont SetFont: Group3
                  s" Name" SetText: Group3
***************
*** 95,99 ****
  
                  self Start: lbl_File_size
!                 60 70 94 18 Move: lbl_File_size
                  Handle: Winfont SetFont: lbl_File_size
                  s" File size (Kb)" SetText: lbl_File_size
--- 99,103 ----
  
                  self Start: lbl_File_size
!                 60 70 94 16 Move: lbl_File_size
                  Handle: Winfont SetFont: lbl_File_size
                  s" File size (Kb)" SetText: lbl_File_size
***************
*** 102,129 ****
                  60 90 94 16 Move: lbl_#Random
                  Handle: Winfont SetFont: lbl_#Random
!                 s" #Random" SetText: lbl_#Random
  
                  self Start: lbl_#Played
!                 60 110 94 18 Move: lbl_#Played
                  Handle: Winfont SetFont: lbl_#Played
                  s" #Played" SetText: lbl_#Played
  
                  self Start: lbl_Drivetype
!                 60 130 77 16 Move: lbl_Drivetype
                  Handle: Winfont SetFont: lbl_Drivetype
                  s" Drivetype" SetText: lbl_Drivetype
  
                  self Start: lbl_Label
!                 60 150 77 16 Move: lbl_Label
                  Handle: Winfont SetFont: lbl_Label
                  s" Label" SetText: lbl_Label
  
                  self Start: R_Filename
!                 60 200 77 16 Move: R_Filename
                  Handle: Winfont SetFont: R_Filename
                  s" Filename" SetText: R_Filename
  
                  self Start: R_Artist_and_title
!                 60 220 104 16 Move: R_Artist_and_title
                  Handle: Winfont SetFont: R_Artist_and_title
                  s" Artist_and_title" SetText: R_Artist_and_title
--- 106,133 ----
                  60 90 94 16 Move: lbl_#Random
                  Handle: Winfont SetFont: lbl_#Random
!                 s" Random" SetText: lbl_#Random
  
                  self Start: lbl_#Played
!                 60 150 94 16 Move: lbl_#Played
                  Handle: Winfont SetFont: lbl_#Played
                  s" #Played" SetText: lbl_#Played
  
                  self Start: lbl_Drivetype
!                 60 170 77 16 Move: lbl_Drivetype
                  Handle: Winfont SetFont: lbl_Drivetype
                  s" Drivetype" SetText: lbl_Drivetype
  
                  self Start: lbl_Label
!                 60 190 77 16 Move: lbl_Label
                  Handle: Winfont SetFont: lbl_Label
                  s" Label" SetText: lbl_Label
  
                  self Start: R_Filename
!                 60 250 77 16 Move: R_Filename
                  Handle: Winfont SetFont: R_Filename
                  s" Filename" SetText: R_Filename
  
                  self Start: R_Artist_and_title
!                 60 270 104 16 Move: R_Artist_and_title
                  Handle: Winfont SetFont: R_Artist_and_title
                  s" Artist_and_title" SetText: R_Artist_and_title
***************
*** 131,135 ****
                  IDOK SetID: Button1
                  self Start: Button1
!                 50 260 50 20 Move: Button1
                  Handle: Winfont SetFont: Button1
                  s" Ok" SetText: Button1
--- 135,139 ----
                  IDOK SetID: Button1
                  self Start: Button1
!                 50 320 50 20 Move: Button1
                  Handle: Winfont SetFont: Button1
                  s" Ok" SetText: Button1
***************
*** 137,141 ****
                  IDcancel SetID: Button2
                  self Start: Button2
!                 120 260 50 20 Move: Button2
                  Handle: Winfont SetFont: Button2
                  s" Cancel" SetText: Button2
--- 141,145 ----
                  IDcancel SetID: Button2
                  self Start: Button2
!                 120 320 50 20 Move: Button2
                  Handle: Winfont SetFont: Button2
                  s" Cancel" SetText: Button2
***************
*** 151,193 ****
                  s" " SetText: s_#Random
  
                  self Start: s_#played
!                 30 110 18 18 Move: s_#played
                  Handle: Winfont SetFont: s_#played
                  s" " SetText: s_#played
  
                  self Start: s_DriveType
!                 30 130 18 18 Move: s_DriveType
                  Handle: Winfont SetFont: s_DriveType
                  s" " SetText: s_DriveType
  
                  self Start: s_label
!                 30 150 18 18 Move: s_label
                  Handle: Winfont SetFont: s_label
                  s" " SetText: s_label
  
                  self Start: s_Filename
!                 30 200 18 18 Move: s_Filename
                  Handle: Winfont SetFont: s_Filename
                  s" " SetText: s_Filename
  
                  self Start: s_Artist_Title
!                 30 220 18 18 Move: s_Artist_Title
                  Handle: Winfont SetFont: s_Artist_Title
                  s" " SetText: s_Artist_Title
  
!         vadr-config dup s_Drivetype-      c@ Check: s_DriveType
!                     dup s_Label-          c@ Check: s_Label
!                     dup s_filesize-       c@ Check: s_filesize
!                     dup s_#Random-        c@ Check: s_#Random
!                     dup s_#Played-        c@ Check: s_#Played
!                     dup s_Filename-       c@ Check: s_Filename
!                     dup s_Artist_Title-   c@ Check: s_Artist_Title
!                     dup l_Index-          c@ Check: lbl_Index
!                     dup l_Drivetype-      c@ Check: lbl_DriveType
!                     dup l_Label-          c@ Check: lbl_Label
!                     dup l_File_size-      c@ Check: lbl_File_size
!                     dup l_#Random-        c@ Check: lbl_#Random
!                     dup l_#Played-        c@ Check: lbl_#Played
!                         l_Filename-       c@
                                 if   CheckButton: R_Filename
                                 else CheckButton: R_Artist_and_title
--- 155,220 ----
                  s" " SetText: s_#Random
  
+                 self Start: s_Random_popular
+                 30 110 18 18 Move: s_Random_popular
+                 Handle: Winfont SetFont: s_Random_popular
+                 s" " SetText: s_Random_popular
+ 
+                 self Start: s_Random_impopular
+                 30 130 18 18 Move: s_Random_impopular
+                 Handle: Winfont SetFont: s_Random_impopular
+                 s" " SetText: s_Random_impopular
+ 
                  self Start: s_#played
!                 30 150 18 18 Move: s_#played
                  Handle: Winfont SetFont: s_#played
                  s" " SetText: s_#played
  
                  self Start: s_DriveType
!                 30 170 18 18 Move: s_DriveType
                  Handle: Winfont SetFont: s_DriveType
                  s" " SetText: s_DriveType
  
                  self Start: s_label
!                 30 190 19 22 Move: s_label
                  Handle: Winfont SetFont: s_label
                  s" " SetText: s_label
  
                  self Start: s_Filename
!                 30 250 18 18 Move: s_Filename
                  Handle: Winfont SetFont: s_Filename
                  s" " SetText: s_Filename
  
                  self Start: s_Artist_Title
!                 30 270 18 18 Move: s_Artist_Title
                  Handle: Winfont SetFont: s_Artist_Title
                  s" " SetText: s_Artist_Title
  
!                 self Start: lbl_Random_popular
!                 60 110 125 16 Move: lbl_Random_popular
!                 Handle: Winfont SetFont: lbl_Random_popular
!                 s" Random popular" SetText: lbl_Random_popular
! 
!                 self Start: lbl_Random_impopular
!                 60 130 130 16 Move: lbl_Random_impopular
!                 Handle: Winfont SetFont: lbl_Random_impopular
!                 s" Random impopular" SetText: lbl_Random_impopular
! 
! 
!         vadr-config dup s_Drivetype-        c@ Check: s_DriveType
!                     dup s_Label-            c@ Check: s_Label
!                     dup s_filesize-         c@ Check: s_filesize
!                     dup s_#Random-          c@ Check: s_#Random
!                     dup s_Random_popular-   c@ Check: s_Random_popular
!                     dup s_Random_impopular- c@ Check: s_Random_impopular
!                     dup s_#Played-          c@ Check: s_#Played
!                     dup s_Filename-         c@ Check: s_Filename
!                     dup s_Artist_Title-     c@ Check: s_Artist_Title
!                     dup l_Index-            c@ Check: lbl_Index
!                     dup l_Drivetype-        c@ Check: lbl_DriveType
!                     dup l_Label-            c@ Check: lbl_Label
!                     dup l_File_size-        c@ Check: lbl_File_size
!                     dup l_#Random-          c@ Check: lbl_#Random
!                     dup l_#Played-          c@ Check: lbl_#Played
!                         l_Filename-         c@
                                 if   CheckButton: R_Filename
                                 else CheckButton: R_Artist_and_title
***************
*** 197,214 ****
  : SaveSettingsForm  ( - )
     vadr-config
!    IsButtonChecked?: s_Drivetype       over s_DriveType-    c!
!    IsButtonChecked?: s_Label           over s_Label-        c!
!    IsButtonChecked?: s_filesize        over s_filesize-     c!
!    IsButtonChecked?: s_#Random         over s_#Random-      c!
!    IsButtonChecked?: s_#Played         over s_#Played-      c!
!    IsButtonChecked?: s_Filename        over s_Filename-     c!
!    IsButtonChecked?: s_Artist_Title    over s_Artist_Title- c!
!    IsButtonChecked?: lbl_Index         over l_Index-        c!
!    IsButtonChecked?: lbl_Drivetype     over l_DriveType-    c!
!    IsButtonChecked?: lbl_Label         over l_Label-        c!
!    IsButtonChecked?: lbl_File_size     over l_File_size-    c!
!    IsButtonChecked?: lbl_#Random       over l_#Random-      c!
!    IsButtonChecked?: lbl_#Played       over l_#Played-      c!
!    IsButtonChecked?: R_Filename        over l_Filename-     c!
     IsButtonChecked?: R_Artist_and_title swap l_Artist_and_title- c!
   ;
--- 224,243 ----
  : SaveSettingsForm  ( - )
     vadr-config
!    IsButtonChecked?: s_Drivetype        over s_DriveType-    c!
!    IsButtonChecked?: s_Label            over s_Label-        c!
!    IsButtonChecked?: s_filesize         over s_filesize-     c!
!    IsButtonChecked?: s_#Random          over s_#Random-      c!
!    IsButtonChecked?: s_Random_popular   over s_Random_popular-   c!
!    IsButtonChecked?: s_Random_impopular over s_Random_impopular- c!
!    IsButtonChecked?: s_#Played          over s_#Played-      c!
!    IsButtonChecked?: s_Filename         over s_Filename-     c!
!    IsButtonChecked?: s_Artist_Title     over s_Artist_Title- c!
!    IsButtonChecked?: lbl_Index          over l_Index-        c!
!    IsButtonChecked?: lbl_Drivetype      over l_DriveType-    c!
!    IsButtonChecked?: lbl_Label          over l_Label-        c!
!    IsButtonChecked?: lbl_File_size      over l_File_size-    c!
!    IsButtonChecked?: lbl_#Random        over l_#Random-      c!
!    IsButtonChecked?: lbl_#Played        over l_#Played-      c!
!    IsButtonChecked?: R_Filename         over l_Filename-     c!
     IsButtonChecked?: R_Artist_and_title swap l_Artist_and_title- c!
   ;
***************
*** 221,226 ****
   ;
  
- \ debug HandleButtons
- 
  :M WM_COMMAND   ( h m w l -- res )
                  over LOWORD ( ID ) self   \ object address on stack
--- 250,253 ----

Index: Pl_Version.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Pl_Version.f,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** Pl_Version.f	19 Oct 2005 19:37:20 -0000	1.14
--- Pl_Version.f	26 Oct 2005 15:19:15 -0000	1.15
***************
*** 3,7 ****
  anew -Pl_Version.f
  
! 10120 value player_version#
  
  \ Version numbers: v.ww.rr
--- 3,7 ----
  anew -Pl_Version.f
  
! 10121 value player_version#
  
  \ Version numbers: v.ww.rr
***************
*** 42,46 ****
   - Columns in the treeview.
   - Only add a new file to the catalog when it wasn't added before
-  - A better stable sort routine
  
  \ ---------------------------------------------------------------------------
--- 42,45 ----
***************
*** 131,136 ****
  
  \ changes for Version 1.01.20
! Jos	October 19th, 2005
! 	- Added a form to define a view.
  
  \s
--- 130,139 ----
  
  \ changes for Version 1.01.20
! Jos     October 19th, 2005
!         - Added a form to define a view.
! 
! \ changes for Version 1.01.21
! Jos     October 26th, 2005
!         - Changed the shellsort and added more vieuws
  
  \s

[Win32forth-cvs] win32forth/apps/Player4 mshell_r.f,NONE,1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12700/apps/Player4

Added Files:
	mshell_r.f 
Log Message:
Jos: 
\ New Characteristics:
\ Multiple keys can be used and can be sorted in one go.
\ The number of keys is limited by the size of the stack.
\ Each key can be ascending or descending sorted.

--- NEW FILE: mshell_r.f ---
anew mshell_rel.f       \  October 24th, 2005

\ A flexible shellsort.

\ Notes:
\ The database and the pointers must be mapped.
\ Minimum file size of the database must be 1 byte.
\ When the database is resized, the database has to be re-mapped.

\ Characteristics:
\ This version saves its pointers as relative offsets in an index file.
\ The sort is case-insensitive.
\ Multiple keys can be used and can be sorted in one go.
\ The number of keys is limited by the size of the stack.
\ Each key can be ascending or descending sorted.



needs w_search.f

    23 value record-size
   112 value #records
     0 value aptrs  \ an array of cells containing pointers to records
     0 value records-pointer

: n>aptr   ( n -- a )   S" aptrs +cells                 " EVALUATE ; IMMEDIATE
: r>record ( n -- a )   S" records-pointer ( CHARS) +   " EVALUATE ; IMMEDIATE
: record>r ( a -- n )   S" records-pointer ( CHARS) -   " EVALUATE ; IMMEDIATE
: n>record ( n -- a )   S" n>aptr @ r>record            " EVALUATE ; IMMEDIATE
\ : n>key    ( n -- a ) S" n>record >key                " EVALUATE ; IMMEDIATE
: records  ( n -- ra )  S" record-size *                " EVALUATE ; IMMEDIATE
: >record  ( n -- a )   S" records r>record             " EVALUATE ; IMMEDIATE
: xchange  ( a1 a2 -- ) S" dup>r @ over @ r> ! swap !   " EVALUATE ; IMMEDIATE
: &key-len ( key - &key-len )   s" cell+                " EVALUATE ; IMMEDIATE
: >key     ( ra - key-start )   s" by @ +               " EVALUATE ; IMMEDIATE
: key-len  ( ra - cnt )         s" by &key-len @        " EVALUATE ; IMMEDIATE

: <>=      ( n1 n2 - -1|0|1 )
   s" 2dup = if  2drop 0  else <  if 1 else  true  then  then " EVALUATE ; IMMEDIATE

: cmp-cell { by }   ( cand1 cand2 by - p1 p2 n )
   >key @ swap >key @  <>=
 ;

: cmp$     { by }   ( cand1 cand2 by - p1 p2 n )
   swap >key swap >key key-len tuck compareia
 ;

: mod-cell    ( n adr offset - ) >r swap r> cells+ !  ;
: Ascending   ( key - key ) dup 0 2 mod-cell ;
: Descending  ( key - key ) dup -1 2 mod-cell ;
: $sort       ( key - )     ['] cmp$ 3 mod-cell ;
: bin-sort    ( key - )     ['] cmp-cell 3 mod-cell ;

: Descending? ( key - )     s" 2 cells+ @ " EVALUATE ; IMMEDIATE

\ Ascending and cmp$ are default in key:
: key: \ Compiletime: ( start len -< name >- )  Runtime ( - adr-key )
   create swap , , 0 , ['] cmp$ ,
 ;

: by[ ( R: -  #stack )                  s" depth >r  "  EVALUATE ; IMMEDIATE
: ]by ( - #stack-inc) ( R: #stack - )   s" depth r> - " EVALUATE ; IMMEDIATE

: CmpBy  ( cand1 cand2  ByStackTop #keys - p1 p2 f )
   true LOCALS| flag #keys  ByStackTop cand2 cand1 |
   #keys 0
        do   cand1 cand2  ByStackTop i cells+ @ dup 3 cells+ @ execute
             dup 0=
                if    drop
                else   ByStackTop i cells+ @ Descending?
                        if    0<
                        else  0>
                        then
                      to flag leave             \ 0=exch
                then

        loop
   flag
 ;

: mshell-rel  ( keyx..key1 #keys aptrs #records -- )
    sp@ 3 cells+ 3 roll LOCALS| #keys by |
    dup 2 <
      if    2drop
      else  1  begin  3 * 1+ 2dup 1+ u< until  \ gap*3
            begin  3 / dup
            while  2dup - >r dup cells r> 0
                      do  dup 4 pick dup i cells +
                            do  dup i + dup @ r>record
                                i tuck @ r>record  by #keys CmpBy
                                    if    2drop  leave
                                    then
                                xchange dup negate
                            +loop  drop
                       loop  drop
           repeat  2drop drop
      then
    sp@ #keys cells+ sp!
  ;

: build-ptrs ( #records -- )
   to #records #records 1+ cells allocate throw  to aptrs  #records 1+ 0
     do   records-pointer i records ( chars ) + aptrs i cells + !
     loop ;

: free-ptrs     ( -- )  aptrs FREE THROW ;
: free-records  ( -- )  records-pointer FREE THROW ;

\ : check-keys  ( -- )
\    space #records 1-
\    0 do  i n>key i 1+ n>key  key-len tuck compareia 0>
\      if ." UN" leave then loop ." sorted " ;

: create-file-ptrs ( name -- )
   count r/w create-file abort" Can't create index file."  close-file throw
 ;

: open-file-ptrs ( name -- hndl )
   count r/w open-file abort" Can't open index file."
 ;

: extend-file ( size hndl - )
    dup>r file-size drop d>s +
    s>d r@ resize-file abort" Can't extend file."
    r> close-file  drop
 ;

: #records-in-database ( m_hndl - #records )  >hfileLength @ record-size /   ;

: add-file-ptrs ( #start #end - )
   dup to #records swap
      do  i records aptrs i cells + !
      loop
 ;

: build-file-ptrs ( #records -- ) 0 swap  add-file-ptrs ;

\s

[Win32forth-cvs] win32forth/apps/Player4 PLAYER4.ff,1.2,1.3

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6499/apps/Player4

Added Files:
	PLAYER4.ff 
Log Message:
readded player4.ff as a binary file

--- NEW FILE: PLAYER4.ff ---
(This appears to be a binary file; contents omitted.)

[Win32forth-cvs] win32forth/apps/Player4 PLAYER4.ff,1.1,NONE

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6183/apps/Player4

Removed Files:
	PLAYER4.ff 
Log Message:
deleted player4.ff (it has the wrong fileformat text/ascii on the CVS)

--- PLAYER4.ff DELETED ---

[Win32forth-cvs] win32forth/apps/Player4 Mediatree.f,1.17,1.18

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29666/apps/Player4

Modified Files:
	Mediatree.f 
Log Message:
Jos: Made a seperator in the treeview to get the title more clear.

Index: Mediatree.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Mediatree.f,v
retrieving revision 1.17
retrieving revision 1.18
diff -C2 -d -r1.17 -r1.18
*** Mediatree.f	19 Oct 2005 19:37:20 -0000	1.17
--- Mediatree.f	20 Oct 2005 17:10:49 -0000	1.18
***************
*** 50,53 ****
--- 50,54 ----
               if     dup RecordDef File_name swap Cnt_File_name  c@
               else   dup RecordDef Artist    over Cnt_Artist     c@ +InlineRecord
+                     s" --" +InlineRecord
                      dup RecordDef Title     swap Cnt_Title      c@
               then

[Win32forth-cvs] win32forth/src Primutil.f,1.12,1.13

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28169/src

Modified Files:
	Primutil.f 
Log Message:
some doc for ,"TEXT" added

Index: Primutil.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Primutil.f,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
*** Primutil.f	12 Oct 2005 22:37:44 -0000	1.12
--- Primutil.f	20 Oct 2005 15:07:18 -0000	1.13
***************
*** 355,359 ****
  
  \ ,"TEXT" also detect \T embeded in the text and replaces it with a TAB char
! 
  : ,"TEXT"       ( -<"text">- )  \ parse out quote delimited text and compile
                                  \ it at here  NO EXTRA SPACES ARE NEEDED !!!
--- 355,360 ----
  
  \ ,"TEXT" also detect \T embeded in the text and replaces it with a TAB char
! \ Note: ,"TEXT" is partly brocken. It only detects and replaces the first \T
! \ in the text all other \T's will not be changed.
  : ,"TEXT"       ( -<"text">- )  \ parse out quote delimited text and compile
                                  \ it at here  NO EXTRA SPACES ARE NEEDED !!!
***************
*** 617,621 ****
                  ( -- hndl )    \ Win32Forths startup initialization
                  0 value
!                 handles-list link, ;     
  
  in-application
--- 618,622 ----
                  ( -- hndl )    \ Win32Forths startup initialization
                  0 value
!                 handles-list link, ;
  
  in-application

[Win32forth-cvs] win32forth/apps/Player4 Catalog.f,1.14,1.15 Mediatree.f,1.16,1.17 PLAYER4.F,1.26,1.27 Pl_Version.f,1.13,1.14 View.f,1.1,1.2

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5453/apps/Player4

Modified Files:
	Catalog.f Mediatree.f PLAYER4.F Pl_Version.f View.f 
Log Message:
Jos: Made the new form operational. Now you can choose what fields you would like to see in the treeview and how they should be sorted.
Delete your old database berfore compiling this version.

Index: Pl_Version.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Pl_Version.f,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -d -r1.13 -r1.14
*** Pl_Version.f	9 Oct 2005 16:33:07 -0000	1.13
--- Pl_Version.f	19 Oct 2005 19:37:20 -0000	1.14
***************
*** 3,7 ****
  anew -Pl_Version.f
  
! 10119 value player_version#
  
  \ Version numbers: v.ww.rr
--- 3,7 ----
  anew -Pl_Version.f
  
! 10120 value player_version#
  
  \ Version numbers: v.ww.rr
***************
*** 40,47 ****
   - BTW the filenames should be stored with relative
   - Addtional search path's
-  - Volume info ( on what DVD/CD has a certain file been stored )
   - Columns in the treeview.
   - Only add a new file to the catalog when it wasn't added before
!  - Only add files to the catalog that can be played by the player
  
  \ ---------------------------------------------------------------------------
--- 40,46 ----
   - BTW the filenames should be stored with relative
   - Addtional search path's
   - Columns in the treeview.
   - Only add a new file to the catalog when it wasn't added before
!  - A better stable sort routine
  
  \ ---------------------------------------------------------------------------
***************
*** 130,132 ****
--- 129,136 ----
  Jos     September 29th, 2005
          - Enabled a fileselector to add files into de catalog
+ 
+ \ changes for Version 1.01.20
+ Jos	October 19th, 2005
+ 	- Added a form to define a view.
+ 
  \s

Index: Mediatree.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Mediatree.f,v
retrieving revision 1.16
retrieving revision 1.17
diff -C2 -d -r1.16 -r1.17
*** Mediatree.f	17 Oct 2005 20:26:31 -0000	1.16
--- Mediatree.f	19 Oct 2005 19:37:20 -0000	1.17
***************
*** 20,59 ****
                  ;M
  
! : +space ( - )  s"  "   InlineRecord +place ;
  
- \ add-record is under construction....
  : add-record    ( n - )   \ Add when not deleted and found in a collection
!                 dup n>record dup RecordDef Deleted- c@ 0= show-deleted = swap RecordDef Excluded- c@ or
!                 if      drop
!                 Else  vadr-config over to lParam 0 InlineRecord !
!                       dup l_Index-  c@
!                           if  over (l.int)  InlineRecord  place +space
!                           then
!                       swap n>record
!                       over l_Drivetype- c@
!                           if   dup RecordDef DriveType c@
!                                DriveType$ InlineRecord +place +space
!                           then
! 
!                         dup RecordDef File_name swap Cnt_File_name c@
! 
!                                         InlineRecord +place
! 
!                   \  dup l_Label-          c@
!                   \  dup l_File_size-      c@
!                   \  dup l_#Played-        c@
!                   \      l_Filename-       c@
!                   \             if   CheckButton: R_Filename
!                   \             else CheckButton: R_Artist_and_title
!                   \             then
! 
! 
!                                         InlineRecord +null
!                                         InlineRecord 1+ to pszText
!                         tvitem->tvins
!                         tvins 0 TVM_INSERTITEMA hWnd Call SendMessage
!                         to hInsertAfter
!                      drop
!                 then
                  ;
  
--- 20,59 ----
                  ;M
  
! : +InlineRecord ( str cnt - )   InlineRecord  +place  s"  " InlineRecord +place ;
! : +(l.int) ( n )                (l.int) +InlineRecord ;
  
  : add-record    ( n - )   \ Add when not deleted and found in a collection
!     dup n>record dup RecordDef Deleted- c@ 0= show-deleted =
!     swap RecordDef Excluded- c@ or
!      if   drop
!      else vadr-config over to lParam 0 InlineRecord !
!           dup l_Index-      c@
!             if   over +(l.int)
!             then
!           swap n>record       \ ( vadr-config rec-addr - )
!           over l_Drivetype- c@
!             if   dup RecordDef DriveType c@ DriveType$ +InlineRecord
!             then
!           over l_Label-     c@
!             if   dup RecordDef MediaLabel over Cnt_MediaLabel c@ +InlineRecord
!             then
!           over l_File_size- c@
!              if  dup RecordDef FileSize @ 1000 / 1 max +(l.int)  \ In KB
!              then
!           over l_#Random-   c@
!              if  dup RecordDef RandomLevel @  +(l.int)
!              then
!           over l_#Played-   c@
!              if  dup RecordDef #played @  +(l.int)
!              then
!           swap l_Filename-  c@
!              if     dup RecordDef File_name swap Cnt_File_name  c@
!              else   dup RecordDef Artist    over Cnt_Artist     c@ +InlineRecord
!                     dup RecordDef Title     swap Cnt_Title      c@
!              then
!           InlineRecord +place
!           InlineRecord +null  InlineRecord 1+ to pszText tvitem->tvins
!           tvins 0 TVM_INSERTITEMA hWnd Call SendMessage to hInsertAfter
!          then
                  ;
  

Index: PLAYER4.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/PLAYER4.F,v
retrieving revision 1.26
retrieving revision 1.27
diff -C2 -d -r1.26 -r1.27
*** PLAYER4.F	17 Oct 2005 20:29:20 -0000	1.26
--- PLAYER4.F	19 Oct 2005 19:37:20 -0000	1.27
***************
*** 90,101 ****
          MENUSEPARATOR
  
!         SUBMENU      "S&ort and show"
             MENUITEM  "Se&t maximum random level"        SetRandomLevel   ;
             MENUITEM  "&Generate random numbers"         RandomizeCatalog ;
-         MENUSEPARATOR
-            MENUITEM  "S&ort by random number"           SortRandom      ;
-            MENUITEM  "Define a view"                    StartViewForm   ;
-            MENUITEM  "S&ort by size"                    SortSize        ;
-            MENUITEM  "S&ort by filename"                SortCatalog     ;
          ENDSUBMENU
  
--- 90,98 ----
          MENUSEPARATOR
  
!         SUBMENU      "S&ort and view"
!            MENUITEM  "Define a view"                    StartViewForm   ;
!         MENUSEPARATOR
             MENUITEM  "Se&t maximum random level"        SetRandomLevel   ;
             MENUITEM  "&Generate random numbers"         RandomizeCatalog ;
          ENDSUBMENU
  
***************
*** 351,355 ****
  :noname ( -- ) \ sort catalog by file names
          catalog-exist?
!         if   sort_by_filename    RefreshCatalog
          then ; is SortCatalog
  
--- 348,352 ----
  :noname ( -- ) \ sort catalog by file names
          catalog-exist?
!         if   SortByFlags   RefreshCatalog
          then ; is SortCatalog
  

Index: Catalog.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/Catalog.f,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** Catalog.f	17 Oct 2005 20:26:31 -0000	1.14
--- Catalog.f	19 Oct 2005 19:37:20 -0000	1.15
***************
*** 30,33 ****
--- 30,34 ----
                  BYTE                    s_Label-
                  BYTE                    s_filesize-
+                 BYTE                    s_#Random-
                  BYTE                    s_#Played-
                  BYTE                    s_Filename-
***************
*** 37,40 ****
--- 38,42 ----
                  BYTE                    l_Label-
                  BYTE                    l_File_size-
+                 BYTE                    l_#Random-
                  BYTE                    l_#Played-
                  BYTE                    l_Filename-
***************
*** 64,83 ****
  
  :struct RecordDef \ catalog
-                 /file_name      Field:  File_name
-                 BYTE                    Cnt_File_name
                  BYTE                    Deleted-
                  BYTE                    Excluded-
                  BYTE                    Played-
                  BYTE                    DriveType
-                 DWORD                   FileSize
                  /MediaLabel     Field:  MediaLabel
-                 BYTE                    Cnt_MediaLabel
                  /artist         Field:  Artist   \ Extracted from the filename
-                 BYTE                    Cnt_Artist
                  /Title          Field:  Title    \ Extracted from the filename
                  BYTE                    Cnt_Title
- Offset Deleted-thread
-                 DWORD                   RandomLevel
-                 DWORD                   #played
                  DWORD                   Not_used1
                  DWORD                   Not_used2
--- 66,85 ----
  
  :struct RecordDef \ catalog
                  BYTE                    Deleted-
                  BYTE                    Excluded-
                  BYTE                    Played-
+                 DWORD                   FileSize 
+ Offset Deleted-thread
+                 DWORD                   RandomLevel
+                 DWORD                   #played
                  BYTE                    DriveType
                  /MediaLabel     Field:  MediaLabel
                  /artist         Field:  Artist   \ Extracted from the filename
                  /Title          Field:  Title    \ Extracted from the filename
+                 /file_name      Field:  File_name
+                 BYTE                    Cnt_File_name
+                 BYTE                    Cnt_MediaLabel
+                 BYTE                    Cnt_Artist
                  BYTE                    Cnt_Title
                  DWORD                   Not_used1
                  DWORD                   Not_used2
***************
*** 313,321 ****
  : sort_by_size          ( - )    by_FileSize    sort-database-bin ;
  
  : sort_by_RandomLevel ( - )
          1 cells                  to key-len
          0 RecordDef RandomLevel  to key-start  sort-database-bin
          0 RecordDef #played      to key-start  sort-database-bin
!         0 RecordDef Deleted-     to key-start  sort-database-bin
  
    ;
--- 315,386 ----
  : sort_by_size          ( - )    by_FileSize    sort-database-bin ;
  
+ : SortByFlags ( - )
+    vadr-config
+      dup>r s_Filename- c@
+         if sort_by_filename  then
+      0 to key-len       maxstring to key-start
+      r@ s_#Random- c@
+         if      1 cells to key-len      0 RecordDef RandomLevel to key-start
+         then
+      r@ s_#Played- c@
+         if      key-len 1 cells +  to key-len
+                 key-start 0 RecordDef #played  min to key-start
+         then
+      r@ s_Drivetype- c@
+         if      key-len 1+ to key-len
+                 key-start 0 RecordDef DriveType min to key-start
+         then
+      r@ s_Label-  c@
+         if      key-len /MediaLabel + to key-len
+                 key-start 0 RecordDef MediaLabel min to key-start
+         then
+      r@ s_Artist_Title- c@
+         if      key-len [ /artist /Title + ] literal + to key-len
+                 key-start 0 RecordDef Artist min to key-start
+         then
+     key-len 0>
+         if      sort-database
+         then
+      r> s_filesize- c@
+         if     sort_by_size
+         then
+  ;
+ 
+ (( : 0SortByFlags ( - ) \ Not yet useable
+    vadr-config
+      dup>r s_Filename- c@
+         if sort_by_filename  then
+ 
+      r@ s_Artist_Title- c@
+         if      [ /artist /Title + ] literal  to key-len
+                 0 RecordDef Artist to key-start
+                 sort-database
+         then
+ 
+      r@ s_#Played- c@
+         if      sort_by_leastPlayed
+         then
+      r@ s_#Random- c@
+         if      1 cells to key-len      0 RecordDef RandomLevel to key-start
+                 sort-database-bin
+         then
+      r@ s_filesize- c@
+         if     sort_by_size
+         then
+      r@ s_Label-  c@
+         if      /MediaLabel to key-len  0 RecordDef MediaLabel  to key-start
+                 sort-database
+         then
+      r> s_Drivetype- c@
+         if      1 to key-len            0 RecordDef DriveType   to key-start
+                 sort-database-bin
+         then
+  ; ))
+ 
  : sort_by_RandomLevel ( - )
          1 cells                  to key-len
          0 RecordDef RandomLevel  to key-start  sort-database-bin
          0 RecordDef #played      to key-start  sort-database-bin
! \        0 RecordDef Deleted-     to key-start  sort-database-bin
  
    ;
***************
*** 344,348 ****
  
     >r                  dup r@ + r@ ascii \ -scan 2dup r@ swap - swap 1+ dup rot \ adr Title
!                        dup>r ascii . scan nip r> swap - dup        \ count artist
                         struct, InlineRecord RecordDef Cnt_Title    c!
                         struct, InlineRecord RecordDef Title swap cmove \ move Title
--- 409,413 ----
  
     >r                  dup r@ + r@ ascii \ -scan 2dup r@ swap - swap 1+ dup rot \ adr Title
!                        dup>r ascii . scan nip r> swap - dup        \ count Title
                         struct, InlineRecord RecordDef Cnt_Title    c!
                         struct, InlineRecord RecordDef Title swap cmove \ move Title
***************
*** 479,481 ****
         then
  ;
- 
--- 544,545 ----

Index: View.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/Player4/View.f,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** View.f	18 Oct 2005 17:11:36 -0000	1.1
--- View.f	19 Oct 2005 19:37:20 -0000	1.2
***************
*** 12,30 ****
  GroupBox Group2
  GroupBox Group3
- CheckBox s_DriveType
- CheckBox s_label
- CheckBox s_filesize
- CheckBox s_#played
  CheckBox lbl_Index
- CheckBox lbl_Drivetype
- CheckBox lbl_Label
  CheckBox lbl_File_size
  CheckBox lbl_#Played
! RadioButton R_Filename
! RadioButton R_Artist_and_title
! CheckBox s_Filename
! CheckBox s_Artist_Title
  PushButton Button1
  PushButton Button2
  
  :M ClassInit:   ( -- )
--- 12,32 ----
  GroupBox Group2
  GroupBox Group3
  CheckBox lbl_Index
  CheckBox lbl_File_size
+ CheckBox lbl_#Random
  CheckBox lbl_#Played
! CheckBox lbl_Drivetype
! CheckBox lbl_Label
! CheckBox R_Filename
! CheckBox R_Artist_and_title
  PushButton Button1
  PushButton Button2
+ RadioButton s_filesize
+ RadioButton s_#Random
+ RadioButton s_#played
+ RadioButton s_DriveType
+ RadioButton s_label
+ RadioButton s_Filename
+ RadioButton s_Artist_Title
  
  :M ClassInit:   ( -- )
***************
*** 51,55 ****
  
  :M StartSize:   ( -- width height )
!                 201 290
                  ;M
  
--- 53,57 ----
  
  :M StartSize:   ( -- width height )
!                 197 290
                  ;M
  
***************
*** 73,110 ****
  
                  self Start: Group1
!                 20 10 164 230 Move: Group1
                  Handle: Winfont SetFont: Group1
                  s" Sort/Group" SetText: Group1
  
                  self Start: Group2
!                 50 30 101 124 Move: Group2
                  Handle: Winfont SetFont: Group2
                  s" Optional" SetText: Group2
  
                  self Start: Group3
!                 50 160 125 70 Move: Group3
                  Handle: Winfont SetFont: Group3
                  s" Name" SetText: Group3
  
-                 self Start: s_DriveType
-                 30 70 18 16 Move: s_DriveType
-                 \ Handle: Winfont SetFont: s_DriveType
-                 \ s" " SetText: s_DriveType
- 
-                 self Start: s_label
-                 30 90 18 16 Move: s_label
-                 \ Handle: Winfont SetFont: s_label
-                 \ s" " SetText: s_label
- 
-                 self Start: s_filesize
-                 30 110 18 16 Move: s_filesize
-                 \ Handle: Winfont SetFont: s_filesize
-                 \ s" " SetText: s_filesize
- 
-                 self Start: s_#played
-                 30 130 18 16 Move: s_#played
-                 \ Handle: Winfont SetFont: s_#played
-                 \ s" " SetText: s_#played
- 
                  self Start: lbl_Index
                  60 50 75 16 Move: lbl_Index
--- 75,92 ----
  
                  self Start: Group1
!                 20 10 159 242 Move: Group1
                  Handle: Winfont SetFont: Group1
                  s" Sort/Group" SetText: Group1
  
                  self Start: Group2
!                 50 30 118 145 Move: Group2
                  Handle: Winfont SetFont: Group2
                  s" Optional" SetText: Group2
  
                  self Start: Group3
!                 50 180 118 63 Move: Group3
                  Handle: Winfont SetFont: Group3
                  s" Name" SetText: Group3
  
                  self Start: lbl_Index
                  60 50 75 16 Move: lbl_Index
***************
*** 112,158 ****
                  s" Index" SetText: lbl_Index
  
                  self Start: lbl_Drivetype
!                 60 70 77 16 Move: lbl_Drivetype
                  Handle: Winfont SetFont: lbl_Drivetype
                  s" Drivetype" SetText: lbl_Drivetype
  
                  self Start: lbl_Label
!                 60 90 76 16 Move: lbl_Label
                  Handle: Winfont SetFont: lbl_Label
                  s" Label" SetText: lbl_Label
  
-                 self Start: lbl_File_size
-                 60 110 66 16 Move: lbl_File_size
-                 Handle: Winfont SetFont: lbl_File_size
-                 s" File size" SetText: lbl_File_size
- 
-                 self Start: lbl_#Played
-                 60 130 77 16 Move: lbl_#Played
-                 Handle: Winfont SetFont: lbl_#Played
-                 s" #Played" SetText: lbl_#Played
- 
                  self Start: R_Filename
!                 60 180 107 16 Move: R_Filename
                  Handle: Winfont SetFont: R_Filename
                  s" Filename" SetText: R_Filename
  
                  self Start: R_Artist_and_title
!                 60 200 101 16 Move: R_Artist_and_title
                  Handle: Winfont SetFont: R_Artist_and_title
!                 s" Artist and title" SetText: R_Artist_and_title
! 
!                 self Start: s_Filename
!                 30 180 18 16 Move: s_Filename
!                 \ Handle: Winfont SetFont: s_Filename
!                 \ s" " SetText: s_Filename
! 
!                 self Start: s_Artist_Title
!                 30 200 19 22 Move: s_Artist_Title
!                 \ Handle: Winfont SetFont: s_Artist_Title
!                 \ s" " SetText: s_Artist_Title
  
                  IDOK SetID: Button1
                  self Start: Button1
!                 40 250 50 20 Move: Button1
                  Handle: Winfont SetFont: Button1
                  s" Ok" SetText: Button1
--- 94,135 ----
                  s" Index" SetText: lbl_Index
  
+                 self Start: lbl_File_size
+                 60 70 94 18 Move: lbl_File_size
+                 Handle: Winfont SetFont: lbl_File_size
+                 s" File size (Kb)" SetText: lbl_File_size
+ 
+                 self Start: lbl_#Random
+                 60 90 94 16 Move: lbl_#Random
+                 Handle: Winfont SetFont: lbl_#Random
+                 s" #Random" SetText: lbl_#Random
+ 
+                 self Start: lbl_#Played
+                 60 110 94 18 Move: lbl_#Played
+                 Handle: Winfont SetFont: lbl_#Played
+                 s" #Played" SetText: lbl_#Played
+ 
                  self Start: lbl_Drivetype
!                 60 130 77 16 Move: lbl_Drivetype
                  Handle: Winfont SetFont: lbl_Drivetype
                  s" Drivetype" SetText: lbl_Drivetype
  
                  self Start: lbl_Label
!                 60 150 77 16 Move: lbl_Label
                  Handle: Winfont SetFont: lbl_Label
                  s" Label" SetText: lbl_Label
  
                  self Start: R_Filename
!                 60 200 77 16 Move: R_Filename
                  Handle: Winfont SetFont: R_Filename
                  s" Filename" SetText: R_Filename
  
                  self Start: R_Artist_and_title
!                 60 220 104 16 Move: R_Artist_and_title
                  Handle: Winfont SetFont: R_Artist_and_title
!                 s" Artist_and_title" SetText: R_Artist_and_title
  
                  IDOK SetID: Button1
                  self Start: Button1
!                 50 260 50 20 Move: Button1
                  Handle: Winfont SetFont: Button1
                  s" Ok" SetText: Button1
***************
*** 160,170 ****
                  IDcancel SetID: Button2
                  self Start: Button2
!                 100 250 50 20 Move: Button2
                  Handle: Winfont SetFont: Button2
                  s" Cancel" SetText: Button2
  
          vadr-config dup s_Drivetype-      c@ Check: s_DriveType
                      dup s_Label-          c@ Check: s_Label
                      dup s_filesize-       c@ Check: s_filesize
                      dup s_#Played-        c@ Check: s_#Played
                      dup s_Filename-       c@ Check: s_Filename
--- 137,183 ----
                  IDcancel SetID: Button2
                  self Start: Button2
!                 120 260 50 20 Move: Button2
                  Handle: Winfont SetFont: Button2
                  s" Cancel" SetText: Button2
  
+                 self Start: s_filesize
+                 30 70 18 18 Move: s_filesize
+                 Handle: Winfont SetFont: s_filesize
+                 s" " SetText: s_filesize
+ 
+                 self Start: s_#Random
+                 30 90 18 18 Move: s_#Random
+                 Handle: Winfont SetFont: s_#Random
+                 s" " SetText: s_#Random
+ 
+                 self Start: s_#played
+                 30 110 18 18 Move: s_#played
+                 Handle: Winfont SetFont: s_#played
+                 s" " SetText: s_#played
+ 
+                 self Start: s_DriveType
+                 30 130 18 18 Move: s_DriveType
+                 Handle: Winfont SetFont: s_DriveType
+                 s" " SetText: s_DriveType
+ 
+                 self Start: s_label
+                 30 150 18 18 Move: s_label
+                 Handle: Winfont SetFont: s_label
+                 s" " SetText: s_label
+ 
+                 self Start: s_Filename
+                 30 200 18 18 Move: s_Filename
+                 Handle: Winfont SetFont: s_Filename
+                 s" " SetText: s_Filename
+ 
+                 self Start: s_Artist_Title
+                 30 220 18 18 Move: s_Artist_Title
+                 Handle: Winfont SetFont: s_Artist_Title
+                 s" " SetText: s_Artist_Title
+ 
          vadr-config dup s_Drivetype-      c@ Check: s_DriveType
                      dup s_Label-          c@ Check: s_Label
                      dup s_filesize-       c@ Check: s_filesize
+                     dup s_#Random-        c@ Check: s_#Random
                      dup s_#Played-        c@ Check: s_#Played
                      dup s_Filename-       c@ Check: s_Filename
***************
*** 174,177 ****
--- 187,191 ----
                      dup l_Label-          c@ Check: lbl_Label
                      dup l_File_size-      c@ Check: lbl_File_size
+                     dup l_#Random-        c@ Check: lbl_#Random
                      dup l_#Played-        c@ Check: lbl_#Played
                          l_Filename-       c@
***************
*** 186,189 ****
--- 200,204 ----
     IsButtonChecked?: s_Label           over s_Label-        c!
     IsButtonChecked?: s_filesize        over s_filesize-     c!
+    IsButtonChecked?: s_#Random         over s_#Random-      c!
     IsButtonChecked?: s_#Played         over s_#Played-      c!
     IsButtonChecked?: s_Filename        over s_Filename-     c!
***************
*** 193,196 ****
--- 208,212 ----
     IsButtonChecked?: lbl_Label         over l_Label-        c!
     IsButtonChecked?: lbl_File_size     over l_File_size-    c!
+    IsButtonChecked?: lbl_#Random       over l_#Random-      c!
     IsButtonChecked?: lbl_#Played       over l_#Played-      c!
     IsButtonChecked?: R_Filename        over l_Filename-     c!
***************
*** 200,204 ****
  : HandleButtons  ( Action/Button - )
              case
!                 IDOK     of SaveSettingsForm close: Self endof
                  IDcancel of close: Self                  endof
              endcase
--- 216,220 ----
  : HandleButtons  ( Action/Button - )
              case
!                 IDOK     of SaveSettingsForm close: Self SortCatalog  endof
                  IDcancel of close: Self                  endof
              endcase

[Win32forth-cvs] win32forth/apps/ForthForm FORMCONTROLS.F,1.2,1.3

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

Update of /cvsroot/win32forth/win32forth/apps/ForthForm
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv21054/win32forth/apps/ForthForm

Modified Files:
	FORMCONTROLS.F 
Log Message:
gah: Removed duplicate IVAR which was causing a redefinition with latest class code (it doesn't appear to be called anywhere, but if so needs to restored with a unique name)

Index: FORMCONTROLS.F
===================================================================
RCS file: /cvsroot/win32forth/win32forth/apps/ForthForm/FORMCONTROLS.F,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** FORMCONTROLS.F	21 Aug 2005 06:22:00 -0000	1.2
--- FORMCONTROLS.F	19 Oct 2005 12:09:55 -0000	1.3
***************
*** 623,627 ****
  ;RecordSize: SizeOf(ctrlData)
  
! BitmapObject ctrlBitmap
  int oldstyle
  
--- 623,627 ----
  ;RecordSize: SizeOf(ctrlData)
  
! \ BitmapObject ctrlBitmap \ doesn't appear to be and causes problems with bytes IVAR above gah
  int oldstyle