Menu
▾
▴
win32forth-cvs — CVS Commit List
You can subscribe to this list here.
| 2004 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
(70) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2005 |
Jan
(38) |
Feb
(4) |
Mar
(11) |
Apr
(49) |
May
(81) |
Jun
(65) |
Jul
(36) |
Aug
(57) |
Sep
(63) |
Oct
(57) |
Nov
(49) |
Dec
(41) |
| 2006 |
Jan
(75) |
Feb
(80) |
Mar
(10) |
Apr
(13) |
May
(100) |
Jun
(100) |
Jul
(77) |
Aug
(87) |
Sep
(80) |
Oct
(124) |
Nov
(39) |
Dec
(41) |
| 2007 |
Jan
(20) |
Feb
(32) |
Mar
(32) |
Apr
(43) |
May
(146) |
Jun
(40) |
Jul
(49) |
Aug
(33) |
Sep
(25) |
Oct
(19) |
Nov
(11) |
Dec
(8) |
| 2008 |
Jan
(4) |
Feb
(11) |
Mar
(31) |
Apr
(40) |
May
(34) |
Jun
(24) |
Jul
(39) |
Aug
(104) |
Sep
(27) |
Oct
(35) |
Nov
(34) |
Dec
(97) |
| 2009 |
Jan
(75) |
Feb
(29) |
Mar
(45) |
Apr
(76) |
May
(121) |
Jun
(103) |
Jul
(67) |
Aug
(28) |
Sep
(22) |
Oct
(39) |
Nov
(9) |
Dec
(15) |
| 2010 |
Jan
(7) |
Feb
(39) |
Mar
(40) |
Apr
(57) |
May
(67) |
Jun
(69) |
Jul
(49) |
Aug
(68) |
Sep
(22) |
Oct
(7) |
Nov
(2) |
Dec
(10) |
| 2011 |
Jan
|
Feb
|
Mar
(10) |
Apr
(4) |
May
(6) |
Jun
(10) |
Jul
(16) |
Aug
(23) |
Sep
(9) |
Oct
|
Nov
(28) |
Dec
(3) |
| 2012 |
Jan
(11) |
Feb
(10) |
Mar
(1) |
Apr
|
May
(4) |
Jun
(3) |
Jul
(3) |
Aug
(4) |
Sep
(2) |
Oct
|
Nov
|
Dec
(1) |
| 2013 |
Jan
|
Feb
(7) |
Mar
(30) |
Apr
(4) |
May
(4) |
Jun
(8) |
Jul
(10) |
Aug
(4) |
Sep
|
Oct
(2) |
Nov
(24) |
Dec
(13) |
| 2014 |
Jan
(7) |
Feb
(2) |
Mar
|
Apr
(1) |
May
(9) |
Jun
|
Jul
(3) |
Aug
(9) |
Sep
|
Oct
(2) |
Nov
|
Dec
(3) |
| 2015 |
Jan
(4) |
Feb
(2) |
Mar
|
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
(5) |
Sep
(1) |
Oct
(4) |
Nov
(7) |
Dec
(39) |
| 2016 |
Jan
(17) |
Feb
(2) |
Mar
(2) |
Apr
|
May
(1) |
Jun
(1) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(1) |
Dec
(2) |
| 2017 |
Jan
|
Feb
(3) |
Mar
|
Apr
|
May
(1) |
Jun
(2) |
Jul
|
Aug
(3) |
Sep
|
Oct
|
Nov
|
Dec
(2) |
| 2018 |
Jan
|
Feb
|
Mar
(2) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2019 |
Jan
|
Feb
|
Mar
(1) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2022 |
Jan
|
Feb
|
Mar
|
Apr
|
May
(1) |
Jun
|
Jul
|
Aug
|
Sep
(1) |
Oct
(2) |
Nov
(1) |
Dec
(1) |
| 2023 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(1) |
Sep
|
Oct
(1) |
Nov
|
Dec
|
| 2025 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: Jos v.d.V. <jo...@us...> - 2007-05-03 20:21:28
|
Update of /cvsroot/win32forth/win32forth-stc/demos In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv29088 Added Files: WINMULTI.F Log Message: Jos: The demo works. But it must be reviewed again. The order of windows is in the ITC and STC version confusing. --- NEW FILE: WINMULTI.F --- \ WINMULTI.F by Wolfgang Engler \ A simple example program to demonstrate multiple window, each having \ its own unique menubar. \ August 2nd, 1996 - 9:21 tjz \ Slight modifications for compatibility with Win32Forth version 3.2. Needs window.f Needs menu.f 0 value HistoryWindow : IDM_Alpha1 z" press this button" z" Alpha1 button" MB_Ok Messagebox: HistoryWindow drop ; : IDM_Beta1 z" press one button" z" Beta1 button" MB_Ok Messagebox: HistoryWindow drop ; MenuBar MyMenu1 popup " T e x u s archive" menuitem "Orsa" IDM_Alpha1 ; menuitem "Magn" IDM_Beta1 ; menuitem "Quit" bye ; endbar \ Define an object "Texus" that is a super object of class "Window" :Object Texus <Super Window :M On_Init: ( -- ) On_Init: super MyMenu1 SetMenuBar: self ;M :M StartSize: ( -- w h ) 200 200 ;M :M StartPos: ( -- x y ) 200 200 ;M :M WindowTitle: ( -- Zstring ) z" Texus Hardware" ;M ;object : DemoTexus ( -- ) Start: Texus ; : UndemoTexus Close: Texus ; \ ---------------------------------------------------------------- : IDM_Alpha z" press this button" z" Alpha button" MB_Ok Messagebox: HistoryWindow drop ; : IDM_Beta z" press one button" z" Beta button" MB_Ok Messagebox: HistoryWindow drop ; MenuBar MyMenu popup " Selection" menuitem " TEXUS" DemoTexus ; menuitem " MAXUS" IDM_Beta ; menuitem "Quit" bye ; endbar \ ------------------------------------------------------------ \ Define an object "History" that is a super object of class "Window" :Object History <Super Window :M ClassInit: ( -- ) ClassInit: super self to HistoryWindow ;M :M On_Init: ( -- ) On_Init: super MyMenu SetMenuBar: self ;M :M StartSize: ( -- w h ) 200 200 ;M :M StartPos: ( -- x y ) 200 200 ;M :M WindowTitle: ( -- Zstring ) z" History of Hardware" ;M \ This is your main window, so it should have the following two definitions, \ so your program will terminate if you close the window. If you don't, \ it won't quit. July 17th, 1996 - 9:20 tjz :M On_Done: ( h m w l -- res ) 0 Call PostQuitMessage drop On_Done: super 0 ;M :M WM_CLOSE ( h m w l -- res ) WM_CLOSE WM: super bye 0 ;M ;Object : DEMO ( -- ) Start: History ; : UNDEMO ( -- ) Close: History ; demo \s with-img ' demo TURNKEY WINMULTI |
|
From: Jos v.d.V. <jo...@us...> - 2007-05-03 20:09:12
|
Update of /cvsroot/win32forth/win32forth-stc/demos In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv23171 Added Files: ROMCALC.F Log Message: Jos: My favorite calculator. --- NEW FILE: ROMCALC.F --- \ ROMCALC.F calculator with Roman numbers by Lars Krueger (( I'm not fully sure how the Romans entered their numbers into their electronic pocket calculators so I chose this method: As you enter the numbers they are added to the number in the display. The numbers starting with 4,5,9 and 1 are handled separately. (see graph below) The --- Button multiplies the displayed number by 1000. After pressing the ENTER-key the number is pushed onto the number stack in the second window. The rest is a regular stack calculator. The following rules are used for constructing the Roman numbers: M 1000 CM 900 D 500 CD 400 C 100 XC 90 L 50 XL 40 X 10 IX 9 V 5 IV 4 I 1 The rule that only three chararacters of the same number ( i.e. III ) can appear in sequence is not handled by the input. I tried it but the graph for the state machine was much too large for a single A4 sheet of paper. If there is a shorter solution than the state machine for this I can't see it in the moment. Anyway, the rule is used in the output. A further less known rule is used to display larger numbers: Factors of one thousand are displayed by painting a line above the factor. Factor of one million are displayed by two and of one billion by three lines. This rule applies only to numbers above 3999 ( the largest number without line). For convenience the numbers are shown as arabic ( in other words normal ) numbers. Examples: 123 CXXIII 2038 MMXXVIII 1996 MCMXCVI 3999 MMMCMXCIX __ 4567 IVDLXVII = 1000002 III =__ 1004567 IIVDLXVII +-------------------------------------+<--+ | | | | else | | | +--------+ | v | | +---+ C,100 +---+ | M, 800 | | 0 |---+---------->| 1 |------+------------+ +---+ | +---+ | ^ | | D, 300 | | +------------+ | ^ | | | else | | +------------+ | | ^ | X,10 +---+ | C, 80 | +---------->| 2 |------+------------+ | +---+ | ^ | | L, 30 | | +------------+ | ^ | | | else | | +------------+ | | ^ | I,1 +---+ | X, 8 | +---------->| 3 |------+------------+ | +---+ | ^ | | V, 3 | | +------------+ | ^ | M, 1000 | +-----------------------------------+ | ^ | D, 500 | +-----------------------------------+ | ^ | L, 50 | +-----------------------------------+ | ^ | V, 5 | +-----------------------------------+ Graph of the finite state machine controlling the number input of the calculator. Initial state is 0. )) Needs window.f Needs controls.f 0 value is-standalone \ cls \ Jos: 2 lines disabled till turnkey works. \ cr .( Do you want this program becoming a standalone executable? ) \ key dup ascii y = swap ascii Y = or to is-standalone \ keep this in one line or use nostack1 is-standalone #if .( Yes. ) #else .( No. ) #endif \ This is the part that actually shows the Roman numbers. \ We need this three times therefore it is not coupled to an object. create romziff ," M" align 1000 , \ This assumes that a cells is larger than ," CM" align 900 , \ 2 byte soo this is makes it not a ," D" align 500 , \ Standard program according to the ," CD" align 400 , \ ANS-document included. ," C" align 100 , ," XC" align 90 , \ Anyway all the Windows stuff is ," L" align 50 , \ non-standard too so nothing to worry about. ," XL" align 40 , ," X" align 10 , \ We keep it simpler this way. First cell ," IX" align 9 , \ string, second cell number. ," V" align 5 , ," IV" align 4 , ," I" align 1 , WinDC globalDC : ((.rom)) { n x y -- } 13 0 do romziff i 2* 1+ cells + @ ( diff ) 0 begin ( diff cnt ) over ( diff cnt diff ) n ( diff cnt diff n ) <= if ( diff cnt ) \ Write the string romziff i 2* cells + count ( diff cnt addr len ) pad +place ( diff cnt ) \ calculate n-diff n ( diff cnt n ) 2 pick ( diff cnt n diff ) - to n ( diff cnt ) then 1+ dup 3 >= until ( diff cnt ) 2drop loop \ Now write the string to hdc. x y pad count TextOut: globalDC ; : 1000^n ( n -- 1000^n ) case 0 of 1 endof 1 of 1000 endof 2 of 1000000 endof 3 of 1000000000 endof endcase ; : (rom.streich) { x y l t -- l } \ Paints t lines of length l above x y t 1+ 1 do y i 3 * - ( y-i ) dup x ( yi yi x ) swap MoveTo: globalDC ( yi ) x l + ( yi xl ) swap LineTo: globalDC loop l ; : ROLL ( n1 n2 .. nk k -- n2 n3 .. nk n1 ) \ ****Rotate k values on the stack, bringing the deepest to the top. DUP>R PICK SP@ DUP CELL+ R> CELLS CELL+ MOVE DROP ; : (.rom) ( n x y t -- n%1000^tiefe x+? y | ) \ Paints a number ( 1 and 999 ) \ * 1000^t. Corrects x,y and n. dup 0= if drop ( n x y ) ((.rom)) else dup 1000^n ( n x y t 1000^t ) dup ( n x y t 1000^t 1000^t) 5 pick ( n x y t 1000^t 1000^t n ) < if ( n x y t 1000^t ) 4 roll ( x y t 1000^t n ) swap 2dup ( x y t n 1^t n 1^t ) / ( x y t n 1^t n/1^t ) 5 pick ( x y t n 1^t n/1 x ) 5 pick ( x y t n 1^t n/1 x y ) ((.rom)) ( x y t n 1^t ) mod ( x y t n ) 3 pick 3 pick ( x y t n x y ) pad count GetTextExtent: globalDC drop ( x y t n x y l ) 4 roll ( x y n x y l t ) (rom.streich) ( x y n l ) \ x+=l 3 roll ( y n l x ) + ( y n x ) 2 roll ( n x y ) s" " pad place \ We clean pad here. Otherwise the sign would be lost. else \ no line above, just clean up ( n x y t 1000^t ) 2drop then then ; : .rom ( n x y hdc -- ) \ Print the positive number n at x y in device context \ hdc. n MUST be positive and y must be larger than 10 if \ n can get larger than 1000. PutHandle: globalDC ( n x y ) 2 pick dup ( n x y n ) 0< if \ negative number drop s" -" else 0= if s" ----" \ zero ( You can put here i.e. s" no number available". ) else s" " \ anything else therefore positive numbers then then pad place ( n x y ) 2 roll abs ( x y n ) 2 roll 2 roll 2 pick ( n x y n ) 3999 <= if ((.rom)) \ In case of numbers below 4000 we can leave out the lines. else 3 ( n x y 3 ) (.rom) 2 (.rom) ( n x y ) 1 (.rom) 0 (.rom) then ; \ Keep these in this order !!! These are used as the rows in the state-machine \ table. 100 constant ID-M 101 constant ID-D 102 constant ID-C 103 constant ID-L 104 constant ID-X 105 constant ID-V 106 constant ID-I \ If you like mix these codes up, change the numbers or not or whatever. 107 constant ID-_ 108 constant ID-+ 109 constant ID-- 110 constant ID-* 111 constant ID-/ 112 constant ID-= 113 constant ID-NEG 114 constant ID-0 115 constant ID-Z 116 constant ID-A :Class AboutWindow <Super Window \ This is largely copied from winhello.f int counter \ a local variable for a counter :M StartSize: ( -- w h ) \ the screen origin of our window 300 150 ;M :M StartPos: ( -- x y ) \ the width and height of our window 200 100 ;M :M WindowStyle: ( -- style ) WS_POPUP WS_BORDER or \ No WS_SYSTEMMENU because we don't \ want to disturb our on/off switch. WS_CAPTION or ;M :M WindowTitle: z" About" ;M \ " What my name ?" asked the window. :M On_Paint: 5 5 s" Roman number calculator" TextOut: dc \ We can change these three to one StaticControl but this \ is easier. 5 30 s" by Lars Krueger" TextOut: dc 5 55 s" email: ai...@rz..." TextOut: dc counter 5 90 GetHandle: dc .rom 5 110 s" seconds open." TextOut: dc ;M :M On_Init: ( -- ) \ things to do at the start of window creation On_Init: super \ do anything superclass needs 0 to counter \ then initialize counter is zero 0 1000 1 hWnd Call SetTimer drop ;M :M WM_TIMER ( h m w l -- res ) \ handle the WM_TIMER events 1 +to counter \ bump the counter Paint: self \ refresh the window 0 ;M :M On_Done: ( -- ) \ things to do before program termination 1 hWnd Call KillTimer drop \ destroy the timer, we are done On_Done: super \ then do things superclass needs ;M :M Start: ( -- ) \ create a new window object s" RomAboutWindow" SetClassName: self Start: super ;M ;Class 10 constant stackmax :Class StackWindow <Super Window int stackptr stackmax 1+ cells bytes nstack :M StartSize: ( -- w h ) \ the screen origin of our window 250 190 ;M :M StartPos: ( -- x y ) \ the width and height of our window 48 200 ;M :M WindowStyle: ( -- style ) WS_POPUP WS_BORDER or WS_CAPTION or ;M :M WindowTitle: z" ROM-Calc-Stack" ;M :M Start: ( -- ) \ create a new window object s" RomStackWindow" SetClassName: self Start: super ;M :M On_Init: ( -- ) \ things to do at the start of window creation 0 to stackptr On_Init: super ;M :M On_Paint: stackptr 10 ( n 10 ) \ From n down to zero begin ( n y ) over while \ Paint the number at 5 y in roman numbers \ and at 5 y+20 in arabic numbers over ( n y n ) 1- cells nstack + @ 5 2 pick ( n y v 5 y ) GetHandle: dc .rom 20 + ( n y+20 ) over 1- cells nstack + @ ( n y v ) 5 2 pick ( n y v 5 y ) 2 pick abs 0 ( n y v 5 y v 0 ) <# #s ( n y v 5 y v 0 ) 4 roll sign #> TextOut: dc ( n y ) 25 + swap 1- swap repeat 2drop ;M :M PushVal: ( n -- ) \ No need to ask for stackptr smaller than stackmax \ because the button will be disabled. nstack stackptr cells+ ! stackptr 1+ stackmax min to stackptr \ prevent stack overflow Paint: self ;M :M PopVal: ( -- n ) \ See above but larger than zero. stackptr 1- 0 max to stackptr \ prevent stack underflow nstack stackptr cells+ @ Paint: self ;M :M CanCalc: ( -- flag ) stackptr 2 >= ;M :M ClearStack: 0 to stackptr Paint: self ;M :M CanEnter: stackptr stackmax < ;M ;Class :Object CalcWindow <Super Window ButtonControl M-Button ButtonControl D-Button ButtonControl C-Button ButtonControl L-Button ButtonControl X-Button ButtonControl V-Button ButtonControl I-Button ButtonControl _-Button ButtonControl +-Button ButtonControl --Button ButtonControl *-Button ButtonControl /-Button ButtonControl =-Button ButtonControl 0-Button ButtonControl N-Button ButtonControl Z-Button ButtonControl A-Button int about StackWindow sw int state int display :M StartSize: ( -- w h ) \ the screen origin of our window 250 190 ;M :M StartPos: ( -- x y ) \ the width and height of our window 304 200 ;M :M WindowStyle: ( -- style ) WS_POPUP WS_BORDER or WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX or ;M :M WindowTitle: z" ROM-Calc" ;M :M Start: ( -- ) \ create a new window object s" RomCalcWindow" SetClassName: self Start: sw \ Start: causes a WM_MOVE message to be \ sent to the window. Therefore we need \ to start sw first or HWND of sw is \ not a valid handle. That would cause a \ Windowserror 87. Start: super FALSE Enable: sw \ 8/7/96 tjz keep user from ckicking \ on the stack window SetFocus: self 0 to about ;M :M On_Paint: 5 5 MoveTo: dc \ A rectangle 245 5 LineTo: dc 245 60 LineTo: dc 5 60 LineTo: dc 5 5 LineTo: dc display 20 20 GetHandle: dc .rom 20 40 display abs 0 <# #s display sign #> TextOut: dc ;M :M On_Init: ( -- ) \ things to do at the start of window creation On_Init: super \ do anything superclass needs \ Our Buttons. We need to set the ID before we create the \ control because Windows wants tho know the ID. ID-M SetID: M-Button self Start: M-Button 05 80 30 20 Move: M-Button s" M" Settext: M-Button ID-D SetID: D-Button self Start: D-Button 40 80 30 20 Move: D-Button s" D" Settext: D-Button ID-C SetID: C-Button self Start: C-Button 75 80 30 20 Move: C-Button s" C" Settext: C-Button ID-L SetID: L-Button self Start: L-Button 05 105 30 20 Move: L-Button s" L" Settext: L-Button ID-X SetID: X-Button self Start: X-Button 40 105 30 20 Move: X-Button s" X" Settext: X-Button ID-V SetID: V-Button self Start: V-Button 75 105 30 20 Move: V-Button s" V" Settext: V-Button ID-I SetID: I-Button self Start: I-Button 05 130 30 20 Move: I-Button s" I" Settext: I-Button ID-_ SetID: _-Button self Start: _-Button 40 130 65 20 Move: _-Button s" ----" Settext: _-Button ID-- SetID: --Button self Start: --Button 125 105 40 20 Move: --Button s" -" Settext: --Button ID-* SetID: *-Button self Start: *-Button 125 130 40 20 Move: *-Button s" *" Settext: *-Button ID-/ SetID: /-Button self Start: /-Button 125 80 40 20 Move: /-Button s" /" Settext: /-Button ID-+ SetID: +-Button self Start: +-Button 125 155 40 20 Move: +-Button s" +" Settext: +-Button ID-= SetID: =-Button self Start: =-Button 05 155 100 20 Move: =-Button s" ENTER" Settext: =-Button ID-0 SetID: 0-Button self Start: 0-Button 170 80 40 20 Move: 0-Button s" 0" Settext: 0-Button ID-NEG SetID: N-Button self Start: N-Button 170 105 40 20 Move: N-Button s" +/-" Settext: N-Button ID-Z SetID: Z-Button self Start: Z-Button 170 130 40 20 Move: Z-Button s" CLR" Settext: Z-Button ID-A SetID: A-Button self Start: A-Button 170 155 40 20 Move: A-Button s" ~~~" Settext: A-Button 0 to state 0 to display false ID-+ EnableDlgItem: self false ID-- EnableDlgItem: self false ID-* EnableDlgItem: self false ID-/ EnableDlgItem: self on_init: sw ;M :M On_Done: ( -- ) \ things to do before program termination about if \ Is the About-box open? Close: about about Dispose then Close: sw On_Done: sw On_Done: super \ then do things superclass needs ;M create state-table \ July 9th, 1997 - 8:56 tjz correction from Pierre Abbat \ Within one state: <<new state>> , <<number to add>> , \ Key State 0 State 1 State 2 State 3 ( M ) 0 , 1000 , 0 , 800 , 0 , 0 , ( n.a. ) 0 , 0 , ( n.a. ) ( D ) 0 , 500 , 0 , 300 , 0 , 0 , ( n.a. ) 0 , 0 , ( n.a. ) ( C ) 1 , 100 , 0 , 100 , 0 , 80 , 0 , 0 , ( n.a. ) ( L ) 0 , 50 , 0 , 50 , 0 , 30 , 0 , 0 , ( n.a. ) ( X ) 2 , 10 , 2 , 10 , 0 , 10 , 0 , 8 , ( V ) 0 , 5 , 0 , 5 , 0 , 5 , 0 , 3 , ( I ) 3 , 1 , 3 , 1 , 3 , 1 , 0 , 1 , (( Original --- \ Within one state: <<new state>> , <<number to add>> , \ Key State 0 State 1 State 2 State 3 ( M ) 0 , 1000 , 0 , 800 , 0 , 0 , ( n.a. ) 0 , 0 , ( n.a. ) ( D ) 0 , 500 , 0 , 300 , 0 , 0 , ( n.a. ) 0 , 0 , ( n.a. ) ( C ) 1 , 100 , 0 , 100 , 0 , 80 , 0 , 0 , ( n.a. ) ( L ) 0 , 50 , 0 , 50 , 0 , 30 , 0 , 0 , ( n.a. ) ( X ) 2 , 10 , 0 , 10 , 0 , 10 , 0 , 8 , ( V ) 0 , 5 , 0 , 5 , 0 , 5 , 0 , 3 , ( I ) 3 , 1 , 0 , 1 , 0 , 1 , 0 , 1 , )) ( n.a. means: this is not allowed by rule ) : state-machine ( key -- ) \ Finds for (state,key) the newstate and the value to \ add to display. \ key -> row in table ID-M - 8 cells * ( row-addr ) state 2* cells state-table + + dup cell+ ( addr addr+cell ) @ display dup 0< if swap - else + then to display @ to state ; :M WM_COMMAND ( wparam lparam -- res ) \ wparam contains the ID of the clicked \ control. Can be done too by using \ the SetFunc: method. This version \ will be longer ( more to type ). swap ( lparam wparam ) case ID-0 of 0 to display Paint: self endof ID-NEG of display negate to display Paint: self endof ID-= of display PushVal: sw 0 to display 0 to state Paint: self endof ID-Z of ClearStack: sw endof ID-+ of PopVal: sw PopVal: sw + PushVal: sw endof ID-- of PopVal: sw PopVal: sw swap - PushVal: sw endof ID-_ of display 1000 * to display 0 to state Paint: self endof ID-* of PopVal: sw PopVal: sw * PushVal: sw endof ID-/ of PopVal: sw PopVal: sw swap dup 0= if swap PushVal: sw else / then PushVal: sw endof ID-A of about if Close: about about Dispose 0 to about else New> AboutWindow to about Start: about then endof ( lparam wparam ) dup state-machine Paint: self endcase display abs 2147483 <= ID-_ EnableDlgItem: self CanCalc: sw dup 2dup ID-+ EnableDlgItem: self ID-- EnableDlgItem: self ID-* EnableDlgItem: self ID-/ EnableDlgItem: self CanEnter: sw ID-= EnableDlgItem: self drop 0 ;M \ These two methods are corrections by Tom Zimmer. This WM_... inheritance is \ cool. I had to correct them a bit ( stackeffects of WM_MOVE WM: super ). :M WM_MOVE ( wparam lparam -- res ) WM_MOVE WM: Super \ move my"self" first drop \ throw away result from Super GetWindowRect: self 2drop \ returns calcwindows real global \ screen coordinates. swap StartSize: sw drop - 6 - swap \ then adjust "sw" left SetWindowPos: sw \ and set its position SetFocus: self \ simplified, just sets the focus 2drop \ get rid of wparam and lparam 0 ;M \ and return a result :M WM_CLOSE ( -- ) \ allow close button to close windows, but doesn't quit Close: self WM_CLOSE WM: Super [ is-standalone #if postpone bye \ only needed for standalone program #endif ] ;M :M WM_SYSCOMMAND ( wparam lparam -- res ) over case SC_MINIMIZE of true Enable: sw \ Nessesary for iconizing. If left \ out, sw keeps a window dup 2 pick ( wp lp lp wp ) WM_SYSCOMMAND GetHandle: sw call SendMessage drop \ We become an icon, the stack becomes an icon. false Enable: sw \ Get rid of the icon. endof SC_RESTORE of true Enable: sw \ See above. dup 2 pick ( wp lp lp wp ) WM_SYSCOMMAND GetHandle: sw call SendMessage drop \ Both come back. false Enable: sw endof endcase hWnd WM_SYSCOMMAND 2swap DefWindowProc: self ;M ;Object Start: CalcWindow \s is-standalone #IF cr cr .( Creating a standalone executable.) : do-romcalc ( -- ) decimal Start: CalcWindow ; with-img ' do-romcalc turnkey romcalc \ Create a standalone program with the \ "Main"-program or -word auto-start. #ELSE : DEMO ( -- ) Start: CalcWindow cr ." Type UNDEMO to finish or close window " ; : UNDEMO ( -- ) Close: CalcWindow ; cr .( Type DEMO to start the calculator ) #ENDIF |
|
From: Jos v.d.V. <jo...@us...> - 2007-05-03 13:27:50
|
Update of /cvsroot/win32forth/win32forth-stc/src/res In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv1524 Added Files: RESFORTH.H Log Message: Jos: Minor needed addition. --- NEW FILE: RESFORTH.H --- //{{NO_DEPENDENCIES}} // Microsoft Visual C++ generated include file. // Used by FORTH.RC // #define ICON_FORTH 100 #define APP_ICON 101 #define IDC_SPLITV 114 #define IDC_SPLITH 115 #define IDC_MAGNIFY 116 #define IDC_HAND 119 #define IDC_HARROW 120 // Next default values for new objects // #ifdef APSTUDIO_INVOKED #ifndef APSTUDIO_READONLY_SYMBOLS #define _APS_NEXT_RESOURCE_VALUE 121 #define _APS_NEXT_COMMAND_VALUE 101 #define _APS_NEXT_CONTROL_VALUE 1000 #define _APS_NEXT_SYMED_VALUE 101 #endif #endif |
|
From: George H. <geo...@us...> - 2007-05-03 09:11:37
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv29733/win32forth-stc/src Added Files: CHILDWND.F CONTROL.F CONTROLS.F Dialog.f WINMSG.F xfiledlg.f Log Message: gah:Ported Control.f and Dialog.f to STC. Added other working Class files --- NEW FILE: WINMSG.F --- \ $Id: WINMSG.F,v 1.1 2007/05/03 09:10:51 georgeahubert Exp $ \ WINMSG.F Windows Message Window Class by Tom Zimmer Require window.f cr .( Loading Message Window...) :Class MSGWINDOW <super window int cols int rows int ontop? int msgactive int msg-string int msg-length :M Classinit: ( -- ) ClassInit: super s" One Moment Please!" to msg-length to msg-string 50 to OriginX 50 to OriginY 0 to cols 0 to rows 0 to msgactive 0 to ontop? ;M :M OnTop: ( f1 -- ) \ should window float on top? to ontop? ;M :M GetActive: ( -- f1 ) \ is the message window active msgactive ;M :M Close: ( -- ) \ close if its open msgactive if Close: super false to msgactive then ;M :M Start: ( -- ) \ create a new window object Close: self register-frame-window drop create-frame-window to hWnd SW_SHOWNOACTIVATE Show: self Update: self SetFocus: self true to msgactive ;M :M WindowStyle: ( -- style ) \ return the window style [ WS_OVERLAPPED WS_CAPTION or WS_THICKFRAME or ] literal ;M :M ExWindowStyle: ( -- extended_style ) ExWindowStyle: super WS_EX_DLGMODALFRAME or ontop? \ is this a modal message? if WS_EX_TOPMOST or \ if so, lock on top then ;M :M WindowTitle: ( -- Zstring ) Z" One Moment Please!" ;M :M MessageText: ( a1 n1 -- ) to msg-length to msg-string 1 to rows msg-string msg-length begin 2dup 0x0D scan 2dup 2>r nip - nip cols max to cols 2r> dup while rows 1+ to rows \ bump row count 2 /string \ and skip CRLF repeat 2drop ;M :M On_Paint: { \ vpos -- } 25 to vpos msg-string msg-length begin dup while 2dup 0x0D scan 2dup 2>r nip - 20 vpos 2swap TextOut: dc 2r> 2 /string vpos 18 + to vpos repeat 2drop ;M :M StartSize: ( -- width height ) \ starting window size cols 9 * 10 + 200 max rows 16 * 50 + ;M :M MinSize: ( -- width height ) StartSize: [ self ] ;M :M MaxSize: ( -- width height ) StartSize: [ self ] ;M :M Refresh: ( -- ) hWnd \ only if not if StartPos: self StartSize: self Move: self Paint: self then ;M ;Class msgwindow msg-window INTERNAL : _message-off ( -- ) Close: msg-window ; ' _message-off is message-off EXTERNAL : message-on ( -- ) GetActive: msg-window if Refresh: msg-window else Start: msg-window then ; : message-origin ( x y -- ) SetOrigin: msg-window ; INTERNAL : ("message) ( f -- ) \ display message window OnTop: msg-window MessageText: msg-window Start: msg-window ; : _"message ( a1 n1 -- ) \ a floating non-modal message box message-off -if FALSE ("message) else 2drop then ; ' _"message is "message : _"top-message ( a1 n1 -- ) \ a floating ON-TOP message box message-off -if TRUE ("message) else 2drop then ; ' _"top-message is "top-message EXTERNAL : zmessage ( z& -- ) MAXCOUNTED 2dup 0 scan nip - "message ; INTERNAL (( InfoWindow implements a class of window that is used to display tooltip messages when the mouse is held over a button. InfoWindow is used inside CONTROL.F in class Control, to implement tooltips. Info window is really just a simple unframed window that allows you to put up some text on the screen at a specified location. The Close: method will take the window down. The window size is automatically adjusted to the text that you put in the window, and handles strings that contain "\n" new line designators. )) :Object InfoWindow <Super MSGWINDOW \ *G Used for old style tool tips. GdiFont msgFont int extentx int extenty 4 cells bytes &InfoRect ColorObject TIPCOLOR 7 constant fwidth 9 constant fheight :M ClassInit: ( -- ) ClassInit: super 0 to extentx 0 to extenty fwidth SetWidth: msgFont fheight SetHeight: msgFont s" MS Sans Serif" SetFaceName: msgFont COLOR_INFOBK Call GetSysColor NewColor: TIPCOLOR ;M :M On_Init: ( -- ) On_Init: super Create: msgFont ;M :M On_Done: ( -- ) Destroy: msgFont On_Done: super ;M :M StartSize: ( -- width height ) \ starting window size extentx extenty ;M :M On_Paint: { \ vpos msgmax -- } SaveDC: dc GetHandle: msgFont SetFont: dc &InfoRect GetClientRect: self Brush: TIPCOLOR &InfoRect GetHandle: dc call FillRect ?win-error TRANSPARENT SetBkMode: dc 0 to vpos 0 to msgmax 0 to extentx msg-string msg-length begin dup while 2dup 0x0D scan 2dup 2>r nip - 2r> 2swap 2dup GetTextExtent: dc >r 3 + extentx max to extentx \ new max width 0 vpos 2swap TextOut: dc 2 /string r> vpos + to vpos vpos 3 + to extenty repeat 2drop RestoreDC: dc ;M :M WindowStyle: ( -- style ) \ return the window style WS_POPUPWINDOW ;M :M ExWindowStyle: ( -- extended_style ) WS_EX_TOOLWINDOW ;M :M Start: ( c"string" x y -- ) rot count to msg-length to msg-string screen-size fheight 4 + - rot min -rot \ clip vertical msg-string msg-length \ actual string 2dup 0x0D scan nip - nip \ len of first line fwidth * - min swap \ clip horizontal SetOrigin: self \ set window origin Close: self register-frame-window drop create-frame-window to hWnd SW_SHOWNOACTIVATE Show: self Update: self true to msgactive OriginX OriginY StartSize: self Move: self ;M ;Object MODULE --- NEW FILE: xfiledlg.f --- \ $Id: xfiledlg.f,v 1.1 2007/05/03 09:10:51 georgeahubert Exp $ \ load print/open replacements for xcalls cr .( Loading Filedialog Functions...) Require Utils.f anew -xfiledlg.f \ ------------------- Common Open/Save/New Dialog funcs ---------------------- WINLIBRARY COMDLG32.DLL internal 1 PROC GetOpenFileName as fdlg-open ( addr -- rc ) 1 PROC GetSaveFileName as fdlg-save ( addr -- rc ) 1 PROC CommDlgExtendedError create ofn-struct 19 cells , 22 CELLS allot \ OPENFILENAME struct \ This struct can be 22 cells for Windows 2000/XP, but NT or less demands 19? \ Lowest common denominator - have gone for 19. : fdlg-filter ( abs-addr -- abs-addr ) \ change all | to \0 in filter dup begin dup c@ ?dup \ fetch char while \ if not end of string [char] | = if 0 over c! then \ make a \0 char+ \ next char repeat drop \ loose addr ; : fdlg-build ( filename diraddr titleaddr specaddr owner -- ) ofn-struct lcount erase \ clear structure ofn-struct cell+ ! \ save owner in hwnd fdlg-filter \ modify filter ofn-struct 3 cells+ ! \ save filter in filter string 1 ofn-struct 6 cells+ ! \ filterindex=1 ofn-struct 12 cells+ ! \ save title ofn-struct 11 cells+ ! \ save initial dir 1+ ofn-struct 7 cells+ ! \ save initial filename maxcounted ofn-struct 8 cells+ ! \ file length ; : fdlg-getfile ( -- filename ) \ fetch filename ofn-struct 7 cells+ @ \ fetch returned filename ; : fdlg-adjfile ( -- filename ) \ adjust filename returned fdlg-getfile \ fetch returned filename dup maxcounted 0 scan drop \ find end of string over - over 1- c! 1- \ adjust filename to cstr ; : fdlg-nofile ( -- filename ) \ return null filename fdlg-getfile \ fetch returned filename 1- 0 over c! \ null string ; : fdlg-openf ( -- ) \ set open flags in struct [ OFN_PATHMUSTEXIST OFN_FILEMUSTEXIST OR OFN_HIDEREADONLY OR OFN_SHAREAWARE OR ] LITERAL ofn-struct 13 cells+ W! \ flags ; : fdlg-newf ( -- ) \ set open flags in struct [ OFN_PATHMUSTEXIST OFN_HIDEREADONLY OR OFN_SHAREAWARE OR ] LITERAL ofn-struct 13 cells+ W! \ flags ; : fdlg-savef ( -- ) \ set save flags in struct [ OFN_OVERWRITEPROMPT OFN_HIDEREADONLY OR ] LITERAL ofn-struct 13 cells+ W! \ flags ; : fdlg-call ( xt -- filename ) \ call GetxxxxFileName ofn-struct swap execute if fdlg-adjfile \ return filename else call CommDlgExtendedError ?dup if ." Error: GetxxxxFileName failed RC=0x" h. abort else fdlg-nofile \ no file to return then then ; : open-dialog ( filename diraddr titleaddr specaddr owner -- filename ) fdlg-build \ build ofn-struct fdlg-openf \ set open flags ['] fdlg-open fdlg-call \ call dialog ; \ rls February 4th, 2002 - 5:47 : open-dialog2 ( filterindx filenam diradr titleadr specadr owner -- filename ) fdlg-build ofn-struct 6 cells+ ! \ set filter index fdlg-openf \ set open flags ['] fdlg-open fdlg-call \ call dialog ; : save-dialog ( filename diraddr titleaddr specaddr owner -- filename ) fdlg-build fdlg-savef \ set save flags ['] fdlg-save fdlg-call \ call dialog ; : save-dialog2 ( filterindx filename diraddr titleaddr specaddr owner -- filename ) fdlg-build ofn-struct 6 cells+ ! \ set filter index fdlg-savef \ set save flags ['] fdlg-save fdlg-call \ call dialog ; : new-dialog ( filename diraddr titleaddr specaddr owner -- filename ) fdlg-build \ build ofn-struct fdlg-newf \ set new flags ['] fdlg-open fdlg-call \ call dialog ; \ rls February 4th, 2002 - 20:18 : new-dialog2 ( filterindex filename diraddr titleaddr specaddr owner -- filename ) fdlg-build ofn-struct 6 cells+ ! \ set filter index fdlg-newf \ set new flags ['] fdlg-open fdlg-call \ call dialog ; external : get-filter-Index ( -- n ) ofn-struct 6 cells+ @ \ get filter index ; internal \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ File dialog Class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :Class FileDialogs <Super Object max-handle bytes szFile max-handle bytes szDir int szFilter int szTitle :M ClassInit: ( -- ) ClassInit: super 0 szDir ! 0 szFile ! here 1+ to szTitle ,"text" max-handle here szTitle - - allot \ extend to max string here 1+ to szFilter ,"text" \ lay in filter, then max-handle here szFilter - - allot \ extend to max string ;M \ Changed to allow Filenames and path's not only in uppercase \ August 31st, 2003 - 12:58 dbu (SF-ID 745382) :M SetDir: ( a1 n1 -- ) \ set the dialog directory string max-handle 2 - min szDir place \ lay in the directory szDir +NULL \ null terminate \ szDir count upper \ make path uppercase - dbu szDir ?-\ \ remove trailing \ ;M :M GetDir: ( -- a1 n1 ) \ get the current dialog directory string szDir count ;M :M SetTitle: ( a1 n1 -- ) szTitle 1- place \ lay in new string szTitle 1- +NULL \ null terminate it ;M \ a new file filter string would be in the following format, with vertical \ bars separating filter name from filter spec, and between filter spec \ and succeeding filter names. \ A maximum of 255 characters is allowed for the total filter specs string \ s" Forth Files (*.f)|*.f|Text Files (*.txt)|*.txt|All Files (*.*)|*.*|" :M SetFilter: ( a1 n1 -- ) \ set new file filter spec szFilter 1- place \ lay in new string szFilter 1- +NULL \ null terminate it ;M :M GetFilter: ( -- a1 n1 ) \ return current file filter string szFilter 1- count ;M \ Changed to allow Filenames and path's not only in uppercase \ August 31st, 2003 - 12:58 dbu (SF-ID 745382) : run-dialog ( owner_handle dialog-func-cfa -- a1 ) 2>r szFile count "to-pathend" szFile place szFile +NULL szFile \ takes a counted string for filename szDir 1+ szTitle szFilter 2r> execute dup count "path-only" szDir place ; ;Class EXTERNAL :Class FileNewDialog <Super FileDialogs :M Start: ( owner_handle -- a1 ) ['] new-dialog run-dialog ;M :M Start2: ( filterindex owner_handle -- a1 ) ['] new-dialog2 run-dialog ;M ;Class :Class FileOpenDialog <Super FileDialogs :M Start: ( owner_handle -- a1 ) ['] open-dialog run-dialog ;M :M Start2: ( filterindex owner_handle -- a1 ) ['] open-dialog2 run-dialog ;M ;Class :Class FileSaveDialog <Super FileDialogs :M Start: ( owner_handle -- a1 ) ['] save-dialog run-dialog ;M :M Start2: ( filterindex owner_handle -- a1 ) ['] save-dialog2 run-dialog ;M ;Class module --- NEW FILE: Dialog.f --- \ $Id: Dialog.f,v 1.1 2007/05/03 09:10:51 georgeahubert Exp $ \ *D doc\classes\ \ *! Dialog \ *T Dialog -- Class for dialog boxes. require generic.f cr .( Loading Dialog Box...) \ *S Load Dialog Resource File \ *P The .RES file structure is a series of records. Each record contains \ ** a header and a data field. The structure of a header is as follows: \ *L \ *| offset | length | | \ *| 0 | 4 | length of data field | \ *| 4 | 4 | length of header | \ *| 10 | 2 | record type | \ *| 14 | 2 | dialog ID number (for dialogs) | : dialogID? ( hdr ID -- f ) \ *G Given the address of a header in a resource file, return true if this \ ** is the header for a dialog resource. I'm only guessing here. over 14 + w@ = \ does ID match swap 10 + w@ 5 = and ; \ is this also a dialog : ?dlgerr ( ior -- ) abort" Error loading dialog resource" ; \ April 18th, 1996 tjz switched to LONG count from WORD count : find-dialog-ID ( id addr -- address-of-template-header ) \ *G Find dialog template given address and length of resource file in memory. swap >r lcount begin over r@ dialogID? if rdrop \ discard the ID drop \ discard the length \ return the template header address EXIT \ ALL DONE, LEAVE then over 2@ + aligned /string dup 0= until 2drop r> cr ." Looking for dialog: " . true ?dlgerr ; \ Read resource file and return address and length of dialog template. in-system \ April 18th, 1996 tjz switched to LONG count from WORD count \ September 21st, 2003 - 13:44 dbu changed to use "open instead of n"open : read-dialog ( name namelen -- ) "open ?dlgerr >r r@ file-size 2drop here ! here lcount dup cell+ allot \ room for file and word cnt r@ read-file ?dlgerr 0= ?dlgerr r> close-file ?dlgerr ; \ changed to work with blanks in file name \ January 31st, 2004 - 20:38 dbu : load-dialog ( -<filename-without-an-extension>- ) \ *G Load template from dialog resource (*.res) to here and allot memory. \n \ ** Usage: load-dialog dialog { \ ld-buf -- } maxstring localalloc: ld-buf >in @ >r \ save the input pointer bl word c@ ( name-max-chars ) 255 > \ check filename length abort" Dialog files are limited to 255 chars" r> >in ! \ restore the input pointer create last @ count \ name length 2dup ld-buf place \ lay in filename s" .res" ld-buf +place \ add extension name.res ld-buf count read-dialog \ load resource file s" fload '" ld-buf place \ load header file ( a1 n1 ) ld-buf +place \ Append filename s" .h'" ld-buf +place \ add extension name.h ld-buf count evaluate postpone \ ; \ ignore rest of line in-application \ *W <a name="Dialog"></a> \ *S Dialog Class :CLASS Dialog <SUPER Dialog&Control \ *G Dialog class. \n \ ** To use this class you have to create a ressource file (*.res) whitch must contain \ ** the dialog resource. Since Win32Forth doesn't provide any tool's to create a dialog \ ** resource you should use ForthForm to create your dialog windows instead. 4 callback: DialogProc ( hwnd msg wparam lparam -- res ) GWL_USERDATA 4 pick Call GetWindowLong ( object address ) ?dup 0= if 2 pick WM_INITDIALOG <> if 0 exit then dup \ window object pointer from \ lparam of DialogBoxIndirectParam 4 pick ( obj hwnd ) 2dup GWL_USERDATA swap Call SetWindowLong drop \ save obj pointer over ! \ set hWnd parameter of window struc then 3 pick ( msg ) over obj>class MFA ((findm)) if MethodExecute else 0 then ; \ 4 callback DialogProc (DialogProc) \ TEMPLATE has been changed to be the template header address, instead of \ the address of the template it self, so we can move the template into \ globally allocated memory : run-dialog { parent template \ tmplhndl -- f } self ['] DialogProc parent 0 <> \ if parent is not zero parent conhndl <> and \ and parent is not the console handle if GetHandle: parent \ then use the specified parent else conhndl \ else use the console for the parent then template 2@ + malloc to tmplhndl template dup cell+ @ + \ from tmplhndl template @ move \ move the length tmplhndl \ new way, template handle appInst Call DialogBoxIndirectParam tmplhndl release ; \ -------------------- Helpers -------------------- :M Start: ( parent -- flag ) \ *G Open the dialog GetTemplate: [ self ] run-dialog ;M :M EndDialog: ( return-value -- ) \ *G Close the dialog hwnd Call EndDialog drop ;M : end-dialog ( value -- flag ) EndDialog: [ self ] 1 ; \ -------------------- Initialization -------------------- :M WM_INITDIALOG swap On_Init: [ self ] ;M :M On_Init: ( hwndfocus -- f ) \ *G Init the dialog drop 1 ;M \ -------------------- Process Commands from Controls -------------------- :M WM_COMMAND ( hwnd msg wparam lparam -- res ) over HIWORD ( notification code ) rot LOWORD ( ID ) On_Command: [ self ] ;M :M On_Command: ( hCtrl code ID -- f ) \ *G Process Commands from Controls case IDOK of 1 end-dialog endof IDCANCEL of 0 end-dialog endof false swap ( default result ) endcase ;M ;Class \ *G End of Dialog class \ December 11th, 2003 jeh, In order to use ModelessDialog you must extend the \ class and add your own GetTemplate method. ( -- template | tmplhndl ) \ The common implementation is to also create a constant to hold \ The template associated with each instance of the class although this is \ not required, only the GetTemplate method is required. \ *W <a name="ModelessDialog"></a> \ *S Modless Dialog class :Class ModelessDialog <SUPER Dialog \ *G Modless Dialog class \n \ ** To use this class you have to create a ressource file (*.res) whitch must contain \ ** the dialog resource. Since Win32Forth doesn't provide any tool's to create a dialog \ ** resource you should use ForthForm to create your dialog windows instead. int hTemplate :M ClassInit: ( -- ) ClassInit: super 0 to hTemplate +dialoglist ;M :M WindowStyle: ( -- n1 ) \ *G Get the window style of the dialog. GetTemplate: [ self ] dup if dup cell+ @ + @ then ;M :M ExWindowStyle: ( -- n1 ) \ *G Get the extended window style of the dialog. GetTemplate: [ self ] dup if dup cell+ @ + cell+ @ then ;M :M Origin: ( -- x y ) \ *G Get the origin (upper left corner) of the dialog. GetTemplate: [ self ] ?dup if dup cell+ @ + 2 cells+ 2 + @ word-split else 0 0 then ;M : run-modeless-dialog { parent template \ tmplhndl -- hwnd tmplhndl } self ['] DialogProc parent 0 <> \ if parent is not zero parent conhndl <> and \ and parent is not the console handle if GetHandle: parent \ then use the specified parent else conhndl \ else use the console for the parent then template 2@ + malloc to tmplhndl template dup cell+ @ + \ from tmplhndl template @ move \ move the length WindowStyle: [ self ] tmplhndl ! ExWindowStyle: [ self ] tmplhndl cell+ ! Origin: [ self ] word-join tmplhndl 2 cells+ 2 + ! tmplhndl \ new way, template handle appInst Call CreateDialogIndirectParam SW_SHOW over Call ShowWindow drop dup Call UpdateWindow drop dup Call SetFocus drop tmplhndl ; :M Start: ( parent -- ) \ *G Open the dialog hTemplate 0= if GetTemplate: [ self ] run-modeless-dialog to hTemplate to hWnd else drop SetFocus: self then ;M :M EndDialog: ( n1 -- ) \ *G Close the dialog drop DestroyWindow: self ;M :M WM_DESTROY ( -- result ) hTemplate release 0 to hTemplate 0 to hwnd 0 ;M :M WM_CLOSE ( -- ) DestroyWindow: Self ;M :M ~: ( -- ) -dialoglist ;M ;Class \ *G End of ModlessDialog class \ *Z --- NEW FILE: CONTROLS.F --- \ $Id: CONTROLS.F,v 1.1 2007/05/03 09:10:51 georgeahubert Exp $ \ CONTROLS.F Additional controls by Freidrick Prinz \ September 7th, 1999 - 22:48 tjz corrected a bug reported by Jos v.c. Ven, \ seems I forgot to initialize the super class of EditControl when I added \ some enhancements. \ July 29th, 1999 - 15:16 tjz enhanced EditControl and ComboControl to \ make them generalized enough to put an edit field on a ToolBar. \ January 9th, 1996 - 13:57 tjz Modified and updated both this file and \ Win32Forth to make this kind of thing easier. Added CONTROL.F to the \ Win32Forth system \ *D doc\classes\ \ *! Controls \ *T Controls -- Classes for standard windows controls. Require Control.f cr .( Loading Low Level Controls...) \ *W <a name="EditControl"></a> \ *S EditControl class :Class EditControl <Super CONTROL \ *G Class for Edit controls. \ ** An edit control is a rectangular control window typically used in a dialog \ ** box to permit the user to enter and edit text by typing on the keyboard. \ pointers to filter function to allow key capturing. int pWmChar \ function returns '0' if it handled message, non-zero otherwise int pWmKeyDown \ function returns '0' if it handled message, non-zero otherwise int pWmKillFocus \ function returns '0' if it handled message, non-zero otherwise \ For backwards compatibility synonym ClientRect wRect synonym ClientRect.addrof wRect.addrof synonym ClientRect.left wRect.left synonym ClientRect.right wRect.right synonym ClientRect.top wRect.top Synonym ClientRect.bottom wRect.bottom :M ClassInit: ( -- ) \ *G Initialise the class. ClassInit: Super 0 to pWmChar 0 to pWmKeyDown 0 to pWmKillFocus ;M :M StartSize: ( -- width height ) \ *G Get the start size of the control. Default size is 100 x 25. 100 25 ;M :M WindowStyle: ( -- Style ) \ *G Get the window style of the control. Default style is: \ ** WS_BORDER, WS_TABSTOP and ES_AUTOHSCROLL. WindowStyle: SUPER [ WS_BORDER WS_TABSTOP OR ES_AUTOHSCROLL OR ] literal OR \ allow horizontal scrolling ;M :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" EDIT" Create-Control ;M :M SetWmChar: ( pWmChar -- ) \ *G Install the WM_CHAR filter function. to pWmChar ;M :M SetWmKeyDown: ( pWmKeyDown -- ) \ *G Install the WM_KEYDOWN filter function. to pWmKeyDown ;M \ *P Install these filter functions if you want to capture certain keys, like \ ** Return or F3, or whatever. :M SetWmKillFocus: ( pWmKillFocus -- ) \ *G Install the WM_KILLFOCUS filter function. to pWmKillFocus ;M :M SubClass: ( hWnd Parent -- ) \ *G Subclass this control. to parent to hWnd subclass ;M : ?pexecute ( hwnd msg wparm lparm pfunction -- result ) -IF self swap execute -IF DROP old-wndproc CallWindowProc THEN ELSE drop old-wndproc CallWindowProc THEN ; :M WM_CHAR ( h m w l -- res ) \ normal & control chars pWmChar ?pexecute ;M (( \ example function to process WM_CHAR messages : myWmChar ( h m w l obj -- res ) 2 pick VK_RETURN = IF GetText: [ ] \ get adr,len of edit control text ...<process WM_CHAR message>... FALSE \ we already processed this message ELSE drop \ discard object TRUE \ and use default processing THEN ; )) :M WM_KEYDOWN ( h m w l -- res ) \ normal & control chars pWmKeyDown ?pexecute ;M :M WM_KILLFOCUS ( h m w l -- res ) \ Allow intervention on kill focus pWmKillFocus ?pexecute ;M :M WM_SETCURSOR { hndl msg wparam lparam -- res } EraseRect: WinRect \ init to zeros AddrOf: WinRect GetClientRect: self hWnd get-mouse-xy Top: WinRect Bottom: WinRect between over Left: WinRect Right: WinRect between and IF ibeam-cursor 1 ELSE DROP hndl msg wparam lparam DefaultWindowProc THEN ;M ;Class \ *G End of EditControl class \ *W <a name="ComboControl"></a> \ *S ComboControl class :Class ComboControl <Super CONTROL \ *G Class for editable combo box controls. EditControl ComboEdit :M StartSize: ( -- width height ) \ *G Get the start size of the control 100 100 ;M :M WindowStyle: ( -- Style ) \ *G Get the window style of the control. The default style is: \ ** CBS_DROPDOWN, WS_VSCROLL, WS_TABSTOP, WS_VISIBLE and ES_AUTOHSCROLL. WindowStyle: SUPER [ CBS_DROPDOWN WS_VSCROLL OR WS_TABSTOP OR WS_VISIBLE OR ES_AUTOHSCROLL OR ] literal OR ;M \ Install these filter functions if you want to capture certain keys, like \ Return or F3, or whatever. :M SetWmChar: ( pWmChar -- ) \ *G install the WM_CHAR filter function for the EditControl of the combo box. SetWmChar: ComboEdit ;M :M SetWmKeyDown: ( pWmKeyDown -- ) \ *G install the WM_KEYDOWN filter function for the EditControl of the combo box. SetWmKeyDown: ComboEdit ;M :M SetWmKillFocus: ( pWmKillFocus -- ) \ *G install the WM_KILLFOCUS filter function for the EditControl of the combo box. SetWmKillFocus: ComboEdit ;M :M InsertString: ( adr len -- ) \ *G Insert a string into the combo box hWnd NULL = \ must have a valid handle IF 2drop \ just discard if not running ELSE 2dup SetText: ComboEdit asciiz dup 0 CB_FINDSTRINGEXACT GetID: self SendDlgItemMessage: parent dup CB_ERR = \ if it's not in list IF DROP 0 CB_INSERTSTRING GetID: self SendDlgItemMessage: parent drop 0 0 CB_SETCURSEL \ set first as current item GetID: self SendDlgItemMessage: parent drop ELSE NIP \ discard string 0 swap CB_SETCURSEL \ set found item as current item GetID: self SendDlgItemMessage: parent drop THEN THEN ;M :M GetString: ( adr index -- ) \ *G Use: GetString: to get indexed items out of the combo box string list \ ** Use: GetText: to get the current combo box string. swap dup>r 1+ swap CB_GETLBTEXT GetID: self SendDlgItemMessage: parent 0 max r> c! ;M :M GetCount: ( -- n1 ) \ *G Use: GetCount: to get the count of items in the combo box string list. 0 0 CB_GETCOUNT GetID: self SendDlgItemMessage: parent 0 max ;M :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" COMBOBOX" Create-Control \ new subclass the embedded EditControl, so we can handle WM_CHAR & WM_KEYDOWN \ messages to capture keys like Return and F3. 5 5 hWnd Call ChildWindowFromPoint self SubClass: ComboEdit 0 0 CB_RESETCONTENT GetID: self SendDlgItemMessage: parent drop ;M ;Class \ *G End of ComboControl class \ *W <a name="ComboListControl"></a> \ *S ComboListControl class :Class ComboListControl <Super ComboControl \ *G Class for select only combo box controls. :M WindowStyle: ( -- Style ) \ *G Get the window style of the control. The default style is: CBS_DROPDOWNLIST. WindowStyle: SUPER CBS_DROPDOWNLIST OR ;M ;Class \ *G End of ComboListControl class \ *W <a name="ListControl"></a> \ *S ListControl class :Class ListControl <Super CONTROL \ *G Class for list box controls. :M WindowStyle: ( -- Style ) \ *G Get the window style of the control. The default style is: WS_VSCROLL, \ ** LBS_NOTIFY, LBS_NOINTEGRALHEIGHT and WS_TABSTOP. WindowStyle: SUPER [ WS_VSCROLL LBS_NOTIFY OR LBS_NOINTEGRALHEIGHT OR WS_TABSTOP OR ] literal OR ;M :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" LISTBOX" Create-Control ;M ;Class \ *G End of ListControlControl class \ *W <a name="GroupControl"></a> \ *S GroupControl control class :Class GroupControl <Super CONTROL \ *G Class for group controls. :M WindowStyle: ( -- Style ) \ *G Get the window style of the control. The default style is: BS_GROUPBOX. WindowStyle: SUPER BS_GROUPBOX OR ;M :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" BUTTON" Create-Control ;M ;Class \ *G End of GroupControl class \ *W <a name="StaticControl"></a> \ *S StaticControl control class :Class StaticControl <Super CONTROL \ *G Class for static controls. :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" STATIC" Create-Control ;M ;Class \ *G End of StaticControl class \ *W <a name="CheckControl"></a> \ *S CheckControl control class :Class CheckControl <Super CONTROL \ *G Class for check box controls. :M WindowStyle: ( -- style ) \ *G Get the window style of the control. The default style is: BS_AUTOCHECKBOX, \ ** and WS_TABSTOP. WindowStyle: SUPER [ BS_AUTOCHECKBOX WS_TABSTOP OR ] literal OR ;M :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" BUTTON" Create-Control ;M ;Class \ *G End of CheckControl class \ *W <a name="RadioControl"></a> \ *S RadioControl control class :Class RadioControl <Super CONTROL \ *G Class for radio button controls. :M WindowStyle: ( -- style ) \ *G Get the window style of the control. The default style is: BS_AUTORADIOBUTTON, \ ** and WS_TABSTOP. WindowStyle: SUPER [ BS_AUTORADIOBUTTON WS_TABSTOP OR ] literal OR ;M :M Start: ( Parent -- ) \ *G Create the control. TO Parent z" BUTTON" Create-Control ;M ;Class \ *G End of RadioControl class \ *W <a name="ButtonControl"></a> \ *S ButtonControl control class :Class ButtonControl <Super CONTROL \ *G Class for push button controls. int buttonfunc :M ClassInit: ( -- ) \ *G Initialise the class. ClassInit: super ['] noop to buttonfunc ;M :M SetFunc: ( cfa -- ) \ *G Set the button function. This function es executed when the \ ** button is pressed whith a click with the left mouse button to buttonfunc ;M :M WindowStyle: ( -- style ) \ *G Get the window style of the control. The default style is: BS_PUSHBUTTON, \ ** and WS_TABSTOP. WindowStyle: SUPER [ BS_PUSHBUTTON WS_TABSTOP OR ] literal OR ;M :M Start: ( Parent -- ) \ *G Create the control. to Parent z" BUTTON" Create-Control ;M :M WM_LBUTTONUP ( h m w l -- res ) hWnd get-mouse-xy hWnd in-button? if buttonfunc execute then old-wndproc CallWindowProc ;M ;Class \ *G End of ButtonControl class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Dialog Window Class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ *W <a name="DialogWindow"></a> \ *S Dialog Window Class :CLASS DialogWindow <Super Window \ *G Base class for windows that contain controls. :M ClassInit: ( -- ) \ *G Initialise the class. ClassInit: super +dialoglist ;M :M ~: ( -- ) -dialoglist ~: super ;M ;Class \ *G End of DialogWindow class \ *Z \s ********* SAMPLE Follows ********* SAMPLE Follows ********* \ ********* SAMPLE Follows ********* SAMPLE Follows ********* \ ********* SAMPLE Follows ********* SAMPLE Follows ********* 0 value check1 :OBJECT EditSample <Super DialogWindow EditControl Edit_1 \ an edit window StaticControl Text_1 \ a static text window ButtonControl Button_1 \ a button ButtonControl Button_2 \ another button CheckControl Check_1 \ a check box RadioControl Radio_1 \ a radio button RadioControl Radio_2 \ another radio button : CloseSample ( -- ) Close: [ self ] ; :M ExWindowStyle: ( -- style ) ExWindowStyle: SUPER ;M :M WindowStyle: ( -- style ) WindowStyle: SUPER [ WS_BORDER WS_OVERLAPPED OR ] literal or ;M :M WindowTitle: ( -- title ) z" " ;M :M StartSize: ( -- width height ) 200 100 ;M :M StartPos: ( -- x y ) 3 3 ;M :M On_Init: ( -- ) On_Init: super self Start: Check_1 4 25 60 20 Move: Check_1 s" Hello" SetText: Check_1 self Start: Radio_1 80 25 80 20 Move: Radio_1 s" Hello2" SetText: Radio_1 GetStyle: Radio_1 \ get the default style WS_GROUP OR SetStyle: Radio_1 \ Start a group self Start: Radio_2 80 45 120 20 Move: Radio_2 s" Hello Again" SetText: Radio_2 self Start: Text_1 \ start up static text GetStyle: Text_1 \ get the default style [ WS_GROUP SS_CENTER OR WS_BORDER OR ] literal OR \ start a group and centre SetStyle: Text_1 \ and border to style 4 4 192 20 Move: Text_1 \ position the window s" Sample Text" SetText: Text_1 \ set the window message self Start: Edit_1 3 72 60 25 Move: Edit_1 s" 000,00" SetText: Edit_1 IDOK SetID: Button_1 self Start: Button_1 110 72 36 25 Move: Button_1 s" OK" SetText: Button_1 GetStyle: Button_1 BS_DEFPUSHBUTTON OR SetStyle: Button_1 self Start: Button_2 150 72 45 25 Move: Button_2 s" Beep" SetText: Button_2 ['] beep SetFunc: Button_2 ;M :M On_Paint: ( -- ) \ screen redraw procedure 0 0 width height LTGRAY FillArea: dc ;M :M Close: ( -- ) GetText: Edit_1 cr type cr Close: SUPER ;M :M WM_COMMAND ( hwnd msg wparam lparam -- res ) over LOWORD ( ID ) case IDOK of Close: self endof GetID: Check_1 of GetID: Check_1 IsDlgButtonChecked: self to check1 beep endof endcase 0 ;M ;OBJECT : demo ( -- ) Start: EditSample ; --- NEW FILE: CHILDWND.F --- \ $Id: CHILDWND.F,v 1.1 2007/05/03 09:10:48 georgeahubert Exp $ \ *D doc\classes\ \ *! Childwnd \ *T Child-Window -- Base class for all child windows \ *S Glossary cr .( Loading Child Window...) only forth also definitions needs window.f :CLASS Child-Window <Super Window \ *G Child-Window is the base class for all child windows. \ *P The windows has a parent, which is the object address, \ ** not the window handle. This allows the child to send \ ** messages to its parent. int id \ id for this child window \ int Parent \ object address of the parent window \ Note: this ivar was moved into the window class some time ago. \ Altough it's not realy needed in the window class I (dbu) left \ it there in order not to break too much code (Sonntag, Juni 04 2006 dbu). :M ClassInit: ( -- ) \ *G Initialise the class. ClassInit: super 0 to id ;M :M SetParent: ( parent -- ) \ *G Set the object address of the parent window. Parent ;M :M GetParent: ( -- parent ) \ *G Get the object address of the parent window. Parent ;M :M SetID: ( n -- ) \ *G Set the ID for this child window. to id ;M :M GetID: ( -- n ) \ *G Get the ID for this child window. id ;M \ To change the minimum window size, override the MinSize: method. \ :M MinSize: ( -- width height ) 0 0 ;M \ override to change \ :M StartSize: ( -- width height ) 0 0 ;M \ override to change \ :M StartPos: ( -- left top ) 0 0 ;M \ override to change \ -------------------- Create Child Window -------------------- \ The child window class has the following properties: \ Private device context (OWNDC) \ Black background \ No icon : register-child-window ( -- f ) \ Register the window class for this child window. WndClassStyle: [ self ] to Style TheWndProc to WndProc 0 to ClsExtra 4 to WndExtra appInst to hInstance NULL to hIcon IDC_ARROW NULL Call LoadCursor to hCursor NULL to hbrBackground NULL to MenuName \ Set the window class name for this child window. Every window \ will become it's own class name and it's own window class. default-class-name WindowClassName 1+ to ClassName register-the-class ; : GetParentWindow ( -- hWnd ) \ Get the parent window handle for this child window. \ If this window has no parent the window of the console is used as the parent. \ If no console is pressent the parent handle will be NULL. Parent if GetHandle: parent else conhndl then \ make shure that we have a valid window handle \ and tell the super class about it. dup call IsWindow 0= if drop NULL then dup SetParentWindow: super ; : create-child-window ( -- hWnd ) \ Create this child window. ^base \ creation parameters appInst \ program instance id \ child id GetParentWindow \ parent window handle StartSize: [ self ] swap \ height, width StartPos: [ self ] swap \ y, x starting position WindowStyle: [ self ] \ the window style WindowTitle: [ self ] \ the window title WindowClassName 1+ \ class name ExWindowStyle: [ self ] \ extended window style Call CreateWindowEx ; :M WindowStyle: ( -- style ) \ *G User windows should override the WindowStyle: method to \ ** set the window style. Default is WS_CHILD and WS_VISIBLE. [ WS_CHILD WS_VISIBLE or ] literal ;M :M WindowTitle: ( -- Zstring ) \ *G User windows should override the WindowTitle: method to \ ** set the window caption. Default is "". z" " ;M \ we don't want a name, pass NULL :M Start: ( Parent -- ) \ *G Create this child window. Parent is the object address of the \ ** parent window. to Parent register-child-window drop create-child-window dup to hWnd if SW_SHOWNORMAL Show: self then ;M :M AutoSize: ( -- ) \ *G Size the window to fit into the client area of the parent window. tempRect.AddrOf GetClientRect: Parent 0 0 Right: tempRect Bottom: tempRect \ x,y,h,w Move: self ;M ;Class \ *G End of Child-Window class \ *Z --- NEW FILE: CONTROL.F --- \ $Id: CONTROL.F,v 1.1 2007/05/03 09:10:51 georgeahubert Exp $ \ *D doc\classes\ \ *! Control \ *T Control -- Class for child controls with subclassing. Require WinMsg cr .( Loading Control Window...) \ child controls with subclassing DEFER SUBCLASS-WNDPROC :NONAME 4DROP 0 ; IS SUBCLASS-WNDPROC \ ------------------------------------------------------------------------ \ ----------------- ITC Only --------------------------------------------- \ ------------------------------------------------------------------------ \ NCODE SUBCLASS-RETURN \ CODE-HERE CELL+ CODE-, \ itc \ mov eax, ebx \ C return value \ mov esp, ebp \ restore stack \ pop ebp \ restore registers \ pop ebx \ pop edi \ pop esi \ ret # 4 CELLS \ return & discard params \ c; \ CFA-CODE SUBCLASS-ENTRY ( lparam wparam message hwnd -- result ) \ push esi \ save registers \ push edi \ push ebx \ push ebp \ mov ebx, ecx \ address of object \ mov ebp, esp \ make forth stacks \ sub esp, # 4000 \ room for return stack \ push 5 CELLS [ebp] \ hwnd \ push 6 CELLS [ebp] \ message \ push 7 CELLS [ebp] \ wparam \ push 8 CELLS [ebp] \ lparam \ xor edi, edi \ EDI is constant 0 \ mov edx, fs: 0x14 \ edx is now ptr from TIB pvArbitrary \ mov esi, # ' SUBCLASS-RETURN \ mov eax, # ' SUBCLASS-WNDPROC \ exec c; \ ------------------------------------------------------------------------ \ -------------------------- STC Only ------------------------------------ \ ------------------------------------------------------------------------ CODE SUBCLASS-ENTRY ( lparam wparam message hwnd -- result ) push esi \ save registers push edi push ebx push ebp mov eax, ecx \ address of object mov ebp, esp \ make forth stacks sub ebp, # 4000 \ room for return stack mov edi, 5 CELLS [esp] \ hwnd mov -4 [ebp], edi mov edi, 6 CELLS [esp] \ message mov -8 [ebp], edi mov edi, 7 CELLS [esp] \ wparam mov -12 [ebp], edi mov edi, 8 CELLS [esp] \ lparam mov -16 [ebp], edi lea ebp, -16 [ebp] mov ebx, fs: 0x14 \ ebx is now ptr from TIB pvArbitrary call ' SUBCLASS-WNDPROC pop ebp \ restore registers pop ebx pop edi pop esi ret # 4 CELLS \ return & discard params c; : CallWindowProc ( hwnd msg wparam lparam wndproc -- result ) >r 4reverse r> Call CallWindowProc ; \ -------------------- Control Class -------------------- \ Support for displaying tool tips; used by the oldstyle buttonbars (e.g. in WinEd). \ Since we have a much better toolbar class in Win32Forth for some time now, I \ (dbu) didn't spend the time to see how this works. And so I didn't document it. INTERNAL \ definitions accessible while defining a buttonbar 0 value &binfo \ pointer to latest defined button create &ButtonRect 4 cells allot \ temp rectangle for current info msg &ButtonRect 4 cells erase create &CursorPoint 2 cells allot &CursorPoint 2 cells erase 255 constant max-binfo \ longest info message allowed : ButtonInfo" ( -- ) \ set the info for latest button or control &binfo 0= abort" Must follow a button definition" '"' word count max-binfo min &binfo place &binfo count \n->crlf ; EXTERNAL \ definitions always accessible TRUE value info-flag \ are we displaying tool tips FALSE value mouse-is-down? : get-mouse-xy { hWnd -- x y } &CursorPoint Call GetCursorPos drop &CursorPoint hWnd Call ScreenToClient drop &CursorPoint @ &CursorPoint cell+ @ ; : in-button? { x y hWnd -- f1 } &ButtonRect hWnd Call GetClientRect drop y &ButtonRect 1 cells+ @ \ 2 + \ top &ButtonRect 3 cells+ @ \ 2 - \ bottom between x &ButtonRect @ \ 2 + \ left &ButtonRect 2 cells+ @ \ 2 - \ right between and ; \ *W <a name="Control"></a> \ *S Generic Control class :Class Control <Super Dialog&Control \ *G Generic control class. \n \ ** Since Control is a generic class it should not be used to create \ ** any instances. \ The following definition must directly precede old-wndproc to work correctly code (old-wndproc) ( ^control -- old-wndproc ) \ address of old window prodedure add eax, # ^class DFA @ mov eax, [eax] next ;c int old-wndproc \ address of old window procedure int parent \ address of parent object int id \ the control's ID int title \ the counted title string int handleofparent \ the frame window handle int Horizontal int Vertical int timering? \ are we opening a popup info window int timerclosed? \ has popup been closed int auto-close? \ does info window automatically close after a time? max-binfo 1+ bytes binfo 32768 value unique-id# : unique-id ( -- id ) \ get a unique initial ID for this control unique-id# 1 +to unique-id# ; \ -------------------- Subclassed Window Procedure -------------------- : _subclass-WndProc ( hwnd msg wparam lparam window -- res ) 3 pick ( msg ) over obj>class MFA ((findm)) if sp0 @ >r sp@ 4 cells+ sp0 ! dup>r MethodCatch ?dup if r@ WndProcError then rdrop r> sp0 ! else (old-wndproc) CallWindowProc then ; ' _subclass-WndProc is subclass-WndProc \ -------------------- SubClassing -------------------- : subclass ( -- ) (controllock) code-here \ for SetWindowLong to pick up 0xC790 code-w, 0xC1 code-c, self code-, \ nop mov ecx, # object 0xE9 code-c, ['] SUBCLASS-ENTRY code-here CELL+ - code-, \ jmp (long) SUBCLASS-ENTRY (controlunlock) GWL_WNDPROC hWnd Call SetWindowLong to old-wndproc \ set ; :M ClassInit: ( -- ) ClassInit: super 0 to parent 0 to handleofparent 0 to old-wndproc unique-id to id z" " to title binfo off binfo to &binfo \ so we can set it later FALSE to timering? FALSE to timerclosed? TRUE to auto-close? ;M :M GetParent: ( -- parent ) \ *G Get the parent window of this control. parent ;M :M GetHandleOfParent: ( -- handleofparent ) \ *G Get the window handle of the parent window of this control. handleofparent ;M :M SetID: ( id -- ) \ *G Set the ID of this control. Normaly you don't need to do this, because \ ** every control get's an unique ID when it's created. to id ;M :M GetID: ( -- id ) \ *G Get the ID of this control id ;M :M ExWindowStyle: ( -- exstyle ) \ *G Get the extended window style of this control 0 ;M :M WindowStyle: ( -- style ) \ *G Get the window style of this control [ WS_CHILD WS_VISIBLE or ] literal ;M :M StartSize: ( -- width height ) \ *G Get the start size of this control. \n \ ** Override this method to change it. 0 0 ;M \ :M StartPos: ( -- left top ) \ *G Get the start position of this control. \n \ ** Override this method to change it. 0 0 ;M :M AutoSize: ( -- ) \ *G Size the window to fit into the client area of the parent window. tempRect.AddrOf GetClientRect: Parent 0 0 Right: tempRect Bottom: tempRect \ x,y,h,w Move: self ;M :M CreateStruct: ( -- CreateStrucPointer ) \ *G This pointer to a structure, depends on what kind of window you are \ ** creating, so we just default it to NULL. NULL ;M : create-control ( z"classname" -- ) >r CreateStruct: [ self ] \ override if needed appInst ID GetHandle: Parent dup to handleofparent StartSize: [ self ] swap \ height, width StartPos: [ self ] swap \ y, x starting position WindowStyle: [ self ] \ you can override these title 1+ \ the control's text r> \ the class name zstring ExWindowStyle: [ self ] \ the extended window style Call CreateWindowEx to hWnd hWnd if subclass then ; \ Support for displaying tool tips; used by the oldstyle buttonbars (e.g. in WinEd). \ Since we have a much better toolbar class in Win32Forth for some time now, I \ (dbu) didn't spend the time to see how this works. And so I didn't document it. 1 constant INFO_START_TIMER \ timer constant 2 constant INFO_END_TIMER \ timer constant 3 constant INFO_CLOSE_TIMER \ timer constant : clear-info ( -- ) INFO_START_TIMER hWnd Call KillTimer drop INFO_END_TIMER hWnd Call KillTimer drop INFO_CLOSE_TIMER hWnd Call KillTimer drop FALSE to timering? FALSE to timerclosed? Close: InfoWindow ; :M BInfo: ( -- a1 ) \ return the counted string of button info binfo ;M :M SetAutoClose: ( flag -- ) \ set the state of the automatic info close feature to auto-close? ;M :M GetAutoClose: ( -- flag ) auto-close? ;M :M WM_TIMER ( h m w l -- res ) hWnd get-mouse-xy to Vertical to Horizontal over INFO_START_TIMER = mouse-is-down? 0= and IF INFO_START_TIMER hWnd Call KillTimer drop Horizontal Vertical hWnd in-button? \ if timer and still on button timering? and IF 1 to timering? BInfo: [ self ] &ButtonRect hWnd Call GetWindowRect drop &ButtonRect @ Horizontal + &ButtonRect cell+ @ Vertical + 25 + Start: InfoWindow NULL 100 INFO_END_TIMER hWnd Call SetTimer drop GetAutoClose: [ self ] IF NULL 4000 INFO_CLOSE_TIMER hWnd Call SetTimer drop THEN ELSE FALSE to timering? THEN THEN over INFO_END_TIMER = IF Horizontal Vertical hWnd in-button? 0= IF INFO_END_TIMER hWnd Call KillTimer drop INFO_CLOSE_TIMER hWnd Call KillTimer drop FALSE to timering? Close: InfoWindow FALSE to timerclosed? THEN THEN over INFO_CLOSE_TIMER = IF INFO_CLOSE_TIMER hWnd Call KillTimer drop FALSE to timering? TRUE to timerclosed? Close: InfoWindow THEN 0 ;M :M amForground?: ( -- f1 ) TRUE ;M :M On_MouseMove: ( h m w -- ) info-flag \ are we displaying tool tips? BInfo: [ self ] c@ and \ and there is text to display IF hWnd get-mouse-xy hWnd in-button? \ in the button ... [truncated message content] |
|
From: George H. <geo...@us...> - 2007-05-03 09:07:18
|
Update of /cvsroot/win32forth/win32forth-stc/src/res In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27988/win32forth-stc/src/res Added Files: Forthdlg.h Forthdlg.res Log Message: gah:Added Dialog resources --- NEW FILE: Forthdlg.h --- #define IDD_FONTDLG 100 #define IDD_FONT 101 #define IDD_CHECK 103 #define IDD_TEXT 104 #define IDD_ABOUT_FORTH 700 #define IDD_ABOUT_HEAD 799 #define IDD_ABOUT_TEXT 701 #define IDD_ABOUT_TEXT2 702 #define IDD_ABOUT_TEXT3 703 #define IDD_ABOUT_TEXT4 704 #define IDD_SAVE_MEMORY 200 #define IDD_AVAIL 202 #define IDD_AVAIL_MEMORY 203 #define IDD_PAGEUP 300 #define IDD_2UP 302 #define IDD_4UP 303 #define IDD_TITLE_TEXT 400 #define IDD_EDIT_TEXT 401 #define IDD_PROMPT_TEXT 404 #define IDD_EDIT_DIALOG 500 #define IDB_OPTION 501 #define IDD_REPLACE_DIALOG 600 #define IDD-PROMPT_TEXT2 601 #define IDD_EDIT_TEXT2 602 #define IDD_EDIT2_DIALOG 800 #define IDD-PROMPT2_TEXT 801 #define IDD_EDIT2_TEXT 802 #define IDOK2 803 #define IDD_PROMPT2_TEXT 804 #define IDOK3 805 --- NEW FILE: Forthdlg.res --- (This appears to be a binary file; contents omitted.) |
|
From: George H. <geo...@us...> - 2007-05-03 09:05:17
|
Update of /cvsroot/win32forth/win32forth-stc/src/res In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27133/res Log Message: Directory /cvsroot/win32forth/win32forth-stc/src/res added to the repository |
|
From: George H. <geo...@us...> - 2007-05-03 09:00:07
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv25317/win32forth-stc/src Modified Files: Menu.f Utils.f primutil.f Log Message: gah:Added more utility words to PrimUtils and Utils. Removed hide form Menus (it was causing the wrong things to be hidden for unnamed menus) Index: Utils.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/Utils.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Utils.f 30 Apr 2007 07:49:26 -0000 1.1 --- Utils.f 3 May 2007 09:00:02 -0000 1.2 *************** *** 17,20 **** --- 17,28 ---- in-application + \ --------------------------------------------------------------------------- + \ ------------------ Miscelaneous Constants --------------------------------- + \ --------------------------------------------------------------------------- + + 260 constant max-handle + ' name>xt alias name> + Library Shell32.dll + : screen-size ( -- width height ) \ get windows screen size SM_CXSCREEN call GetSystemMetrics \ screen width *************** *** 630,635 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! module \s ! internal fload builtby.f --- 638,643 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ module \s ! (( internal fload builtby.f *************** *** 642,646 **** else drop then ; ! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 20 Random number generator for Win32Forth --- 650,654 ---- else drop then ; ! )) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 20 Random number generator for Win32Forth *************** *** 673,677 **** \ 21 Delay Time Words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! \ old Win32s support removed \ September 17th, 2003 - 10:38 dbu --- 681,685 ---- \ 21 Delay Time Words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! (( \ old Win32s support removed \ September 17th, 2003 - 10:38 dbu *************** *** 760,764 **** EXTERNAL ! : make-cursor ( cursor_constant appinst -- ) create , , --- 768,772 ---- EXTERNAL ! )) : make-cursor ( cursor_constant appinst -- ) create , , *************** *** 797,801 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! in-system --- 805,809 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! (( in-system *************** *** 808,812 **** POSTPONE evaluate POSTPONE ; immediate ; ! MODULE --- 816,820 ---- POSTPONE evaluate POSTPONE ; immediate ; ! )) MODULE Index: primutil.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v retrieving revision 1.28 retrieving revision 1.29 diff -C2 -d -r1.28 -r1.29 *** primutil.f 30 Apr 2007 07:49:26 -0000 1.28 --- primutil.f 3 May 2007 09:00:02 -0000 1.29 *************** *** 163,166 **** --- 163,180 ---- ' _\n->crlf is \n->crlf \ link into kernel deferred word + : -null, ( -- ) + 5 0 \ remove previous nulls + do here 1- c@ ?leave + -1 ALLOT + loop ; + + : Z", ( addr len -- ) \ W32F String Extra + \ *G Compile the string, addr len at here. + HERE OVER ALLOT swap cmove ; + + : Z," ( -<string">- ) \ compile string" at here + HERE [CHAR] " PARSE Z", 0 C, ALIGN ZCOUNT \N->CRLF + ; + \ Moved to user area to make asciiz thread safe gah 28jun04 MAXSTRING newuser z-buf *************** *** 172,175 **** --- 186,195 ---- z-buf ascii-z ; + : +z," ( -<text">- ) + -null, z," ; + + : +z", ( a1 n1 -- ) + -null, z", ; + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ *************** *** 355,358 **** --- 375,394 ---- ; + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + \ Limited support for the '#define' statment from 'C' + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + + in-system + + : #define ( -<name expression>- ) + >in @ >r + bl word drop bl word 1+ c@ [char] " = + r> >in ! + if create /parse-s$ count ", + else >in @ >r bl word drop interpret r> >in ! constant bl word drop + then ; + + in-application + \ ------------------------------------------------------------------------ \ Often used Index: Menu.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/Menu.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Menu.f 30 Apr 2007 07:49:26 -0000 1.1 --- Menu.f 3 May 2007 09:00:02 -0000 1.2 *************** *** 262,266 **** NextId to mid :noname to mfunc ! hide !csp BREAK_FLAG to BROKEN_FLAG 0 to BREAK_FLAG --- 262,266 ---- NextId to mid :noname to mfunc ! !csp BREAK_FLAG to BROKEN_FLAG 0 to BREAK_FLAG *************** *** 536,544 **** : (ClassInit) ( -- ) [ warning on ] ! ClassInit: super ! m"text" ! :noname to mfunc ! hide !csp ! ; in-application --- 536,540 ---- : (ClassInit) ( -- ) [ warning on ] ! ClassInit: super m"text" :noname to mfunc !csp ; in-application |
|
From: George H. <geo...@us...> - 2007-05-03 08:56:31
|
Update of /cvsroot/win32forth/win32forth-stc/src/console In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv24650/win32forth-stc/src/console Added Files: Forthdlg.f Log Message: gah:Added about and other forth dialogs (mesage needs rewriting). --- NEW FILE: Forthdlg.f --- \ $Id: Forthdlg.f,v 1.1 2007/05/03 08:56:27 georgeahubert Exp $ Require Dialog cr .( Loading Forth System Dialogs...) only forth also definitions load-dialog FORTHDLG \ load the dialogs for Forth INTERNAL \ start of non-user definitions \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ About Win32forth \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :Object about-forth-dialog <SUPER dialog IDD_ABOUT_FORTH forthdlg find-dialog-id constant template create about-head z," Win32Forth STC (GPL 2005)" create about-msg1 z," Version: " -null, version# ((version)) +z", +z," " \ some extra spaces for safety +z," \nCompiled: " compile-version >date" +z", +z," , " compile-version >time" +z", +z," \nContributors (up to ITC V4.2):\n" +z," Andrew McKewan, Tom Zimmer, Jim Schneider,\n" +z," Robert Smith, Y. T. Lin, Andy Korsak" create about-msg2 z," Portions derived from:\n F-PC Forth, Public Domain, November 1987\n" +z," Assembler 486ASM.F:\n LGPL (c) September 1994, Jim Schneider \n" create about-msg3 z," STC version developement by:\n" +z," Dirk Busch, George Hubert, Alex McDonald,\n" +z," Jos v.d. Ven\n" +z," other's contributions acknowledged\n" :M On_Init: ( hWnd-focus -- f ) about-head zcount IDD_ABOUT_HEAD SetDlgItemText: self about-msg1 zcount IDD_ABOUT_TEXT SetDlgItemText: self about-msg2 zcount IDD_ABOUT_TEXT2 SetDlgItemText: self about-msg3 zcount IDD_ABOUT_TEXT3 SetDlgItemText: self 1 ;M :M Start: ( -- f ) template run-dialog ;M :M On_Command: ( hCtrl code ID -- f1 ) case IDCANCEL of 0 end-dialog endof false swap ( default result ) endcase ;M ;Object EXTERNAL : about-win32forth ( -- ) conhndl start: about-forth-dialog drop ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :Object page-up-dialog <SUPER dialog IDD_PAGEUP forthdlg find-dialog-id constant template :M On_Init: ( hWnd-focus -- f ) 1 ;M :M Start: ( parent-window -- n1 ) \ return size of image template run-dialog ;M :M On_Command: ( hCtrl code ID -- f1 ) case IDCANCEL of 0 end-dialog endof IDD_2UP of 2 end-dialog endof IDD_4UP of 4 end-dialog endof false swap ( default result ) endcase ;M ;Object : page-up-setup ( -- ) conhndl Start: page-up-dialog to #pages-up ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Edit text dialog Class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :Class NewEditDialog <Super dialog IDD_EDIT_DIALOG forthdlg find-dialog-id constant template int szText int szTitle int szPrompt int szDoit int szCancel int szOption int OptionState :M ClassInit: ( -- ) ClassInit: super here to szText 0 , \ null text string here to szTitle ,"text" here to szPrompt ,"text" here to szDoit ,"text" here to szCancel ,"text" here to szOption ,"text" ;M :M On_Init: ( hWnd-focus -- f ) \ Setting the title must be handled specially, since the dialog itself isn't \ considered to be a dialog item szTitle count SetText: self szText count IDD_EDIT_TEXT SetDlgItemText: self szPrompt count IDD_PROMPT_TEXT SetDlgItemText: self szOption c@ if szOption count IDB_OPTION SetDlgItemText: self OptionState IDB_OPTION CheckDlgButton: self TRUE else FALSE then IDB_OPTION ShowDlgItem: self szDoit count dup if 2dup IDOK SetDlgItemText: self then 2drop szCancel count dup if 2dup IDCANCEL SetDlgItemText: self then 2drop 1 ;M :M Start: ( counted_text_buffer parent -- f ) swap to szText template run-dialog ;M :M On_Command: ( hCtrl code ID -- f1 ) \ returns 0=cancel, \ returns 1=option-off \ returns 2=option-on case IDOK of szText 1+ max-handle 2 - IDD_EDIT_TEXT GetDlgItemText: self szText c! IDB_OPTION IsDlgButtonChecked: self dup to OptionState 1 and 1+ end-dialog endof IDCANCEL of 0 end-dialog endof false swap ( default result ) endcase ;M :M SetOptionState: ( n -- ) to OptionState ;M ;Class MODULE \ finish up the module only forth also definitions |
|
From: George H. <geo...@us...> - 2007-05-03 08:49:28
|
Update of /cvsroot/win32forth/win32forth-stc/demos In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv22727/win32forth-stc/demos Added Files: ControlDemo.f Log Message: gah:Added demo for controls (from Controls.f) --- NEW FILE: ControlDemo.f --- \ $Id: ControlDemo.f,v 1.1 2007/05/03 08:49:21 georgeahubert Exp $ \ Moved to it's own file to make it easier to load (at least til copy/paste works Require Controls.f \ ********* SAMPLE Follows ********* SAMPLE Follows ********* 0 value check1 :OBJECT EditSample <Super DialogWindow EditControl Edit_1 \ an edit window StaticControl Text_1 \ a static text window ButtonControl Button_1 \ a button ButtonControl Button_2 \ another button CheckControl Check_1 \ a check box RadioControl Radio_1 \ a radio button RadioControl Radio_2 \ another radio button : CloseSample ( -- ) Close: [ self ] ; :M ExWindowStyle: ( -- style ) ExWindowStyle: SUPER ;M :M WindowStyle: ( -- style ) WindowStyle: SUPER [ WS_BORDER WS_OVERLAPPED OR ] literal or ;M :M WindowTitle: ( -- title ) z" " ;M :M StartSize: ( -- width height ) 200 100 ;M :M StartPos: ( -- x y ) 3 3 ;M :M On_Init: ( -- ) On_Init: super self Start: Check_1 4 25 60 20 Move: Check_1 s" Hello" SetText: Check_1 self Start: Radio_1 80 25 80 20 Move: Radio_1 s" Hello2" SetText: Radio_1 GetStyle: Radio_1 \ get the default style WS_GROUP OR SetStyle: Radio_1 \ Start a group self Start: Radio_2 80 45 120 20 Move: Radio_2 s" Hello Again" SetText: Radio_2 self Start: Text_1 \ start up static text GetStyle: Text_1 \ get the default style [ WS_GROUP SS_CENTER OR WS_BORDER OR ] literal OR \ start a group and centre SetStyle: Text_1 \ and border to style 4 4 192 20 Move: Text_1 \ position the window s" Sample Text" SetText: Text_1 \ set the window message self Start: Edit_1 3 72 60 25 Move: Edit_1 s" 000,00" SetText: Edit_1 IDOK SetID: Button_1 self Start: Button_1 110 72 36 25 Move: Button_1 s" OK" SetText: Button_1 GetStyle: Button_1 BS_DEFPUSHBUTTON OR SetStyle: Button_1 self Start: Button_2 150 72 45 25 Move: Button_2 s" Beep" SetText: Button_2 ['] beep SetFunc: Button_2 ;M :M On_Paint: ( -- ) \ screen redraw procedure 0 0 width height LTGRAY FillArea: dc ;M :M Close: ( -- ) GetText: Edit_1 cr type cr Close: SUPER ;M :M WM_COMMAND ( hwnd msg wparam lparam -- res ) over LOWORD ( ID ) case IDOK of Close: self endof GetID: Check_1 of GetID: Check_1 IsDlgButtonChecked: self to check1 beep endof endcase 0 ;M ;OBJECT : demo ( -- ) Start: EditSample ; |
|
From: Alex M. <ale...@us...> - 2007-05-02 05:54:04
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv27231 Modified Files: dis486.f Log Message: arm: further minor optimisations to disassembler Index: dis486.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/dis486.f,v retrieving revision 1.17 retrieving revision 1.18 diff -C2 -d -r1.17 -r1.18 *** dis486.f 11 Apr 2007 20:20:28 -0000 1.17 --- dis486.f 2 May 2007 05:53:57 -0000 1.18 *************** *** 76,80 **** 0 value dis.16bit \ start in 32 bit mode 0 value dis.base-addr \ no offset by default ! 0 value dis.size \ size of immediate 0 value dis.data16 \ 16 bit data 0 value dis.addr16 \ 16 bit address --- 76,80 ---- 0 value dis.16bit \ start in 32 bit mode 0 value dis.base-addr \ no offset by default ! 0 value dis.size \ size of data in opcode 0 value dis.data16 \ 16 bit data 0 value dis.addr16 \ 16 bit address *************** *** 124,134 **** : .far ." far " ; : .al, ." al, " ; : .ax, ." ax, " ; : .eax, ." eax, " ; : .dx ." dx" ; ! ! : .# ( -- ) ." # " ; ! : ., ( -- ) ." , " ; : ??? ( n1 -- ) .sop" ???" drop ; --- 124,135 ---- : .far ." far " ; + : .# ( -- ) ." # " ; + : ., ( -- ) ." , " ; + : .al, ." al, " ; : .ax, ." ax, " ; : .eax, ." eax, " ; : .dx ." dx" ; ! : .,cl ." , cl" ; : ??? ( n1 -- ) .sop" ???" drop ; *************** *** 152,155 **** --- 153,157 ---- : bits3-5 ( n -- n' ) 3 rshift bits0-2 ; inline \ isolate bits 3 thru 5 : bits3-4 ( n -- n' ) 3 rshift bits0-1 ; inline \ isolate bits 3 thru 4 + : bits4-5 ( n -- n' ) 4 rshift bits0-1 ; inline \ isolate bits 4 thru 5 : bit3 ( n -- f ) %1000 and %1000 = ; : bit2 ( n -- f ) %0100 and %0100 = ; *************** *** 252,257 **** : r,r/m ( adr -- adr' ) ! count dup bits3-5 ( op/reg->reg/m ) ! .reg ., mod-r/m ; : r/m,r ( adr -- adr' ) --- 254,258 ---- : r,r/m ( adr -- adr' ) ! count dup bits3-5 .reg ., mod-r/m ; ( op/reg->reg/m ) : r/m,r ( adr -- adr' ) *************** *** 330,338 **** pre rep "repz " pre lok "lock" ! pre d16a "d16:" ! pre a16a "a16:" ! : d16 ( adr code -- adr' ) d16a true to dis.data16 ; ! : a16 ( adr code -- adr' ) a16a true to dis.addr16 ; : aam ( adr code -- adr' ) .sop" aam" drop count drop ; --- 331,339 ---- pre rep "repz " pre lok "lock" ! \ pre d16a "d16:" ! \ pre a16a "a16:" ! : d16 ( adr code -- adr' ) drop true to dis.prefix-op true to dis.data16 ; ! : a16 ( adr code -- adr' ) drop true to dis.prefix-op true to dis.addr16 ; : aam ( adr code -- adr' ) .sop" aam" drop count drop ; *************** *** 416,419 **** --- 417,423 ---- \ -------------------- Move -------------------- + : .mov ( addr op -- addr' n m ) + .sop-mov drop count dup ; + : mov ( addr op -- addr' ) .sop-mov r/m ; : mri ( addr op -- addr' ) *************** *** 425,429 **** : mvi ( adr op -- adr' ) ( mov mem, imm ) .sop-mov drop count mod-r/m ., ! dis.size IF .imm16/32 ELSE .imm8 --- 429,433 ---- : mvi ( adr op -- adr' ) ( mov mem, imm ) .sop-mov drop count mod-r/m ., ! dis.size \ \\\\ IF .imm16/32 ELSE .imm8 *************** *** 433,440 **** : mrs ( addr op -- addr' ) dis.data16 ! IF .sop-mov drop ! 1 to dis.size ! count dup mod-r/m ., ! .sreg ELSE ??? THEN ; --- 437,441 ---- : mrs ( addr op -- addr' ) dis.data16 ! IF .mov r/m16/32 ., .sreg ELSE ??? THEN ; *************** *** 442,458 **** : msr ( addr op -- addr' ) dis.data16 ! IF .sop-mov drop ! 1 to dis.size ! count dup .sreg ., ! mod-r/m ELSE ??? THEN ; ! : mrc ( addr op -- addr' ) .sop-mov drop count dup .reg32 ., .creg ; ! : mcr ( addr op -- addr' ) .sop-mov drop count dup .creg ., .reg32 ; ! : mrd ( addr op -- addr' ) .sop-mov drop count dup .reg32 ., .dreg ; ! : mdr ( addr op -- addr' ) .sop-mov drop count dup .dreg ., .reg32 ; ! : mrt ( addr op -- addr' ) .sop-mov drop count dup .reg32 ., .treg ; \ obsolete ! : mtr ( addr op -- addr' ) .sop-mov drop count dup .treg ., .reg32 ; \ obsolete : mv1 ( addr op -- addr' ) --- 443,456 ---- : msr ( addr op -- addr' ) dis.data16 ! IF .mov .sreg ., r/m16/32 ELSE ??? THEN ; ! : mrc ( addr op -- addr' ) .mov .reg32 ., .creg ; ! : mcr ( addr op -- addr' ) .mov .creg ., .reg32 ; ! : mrd ( addr op -- addr' ) .mov .reg32 ., .dreg ; ! : mdr ( addr op -- addr' ) .mov .dreg ., .reg32 ; ! : mrt ( addr op -- addr' ) .mov .reg32 ., .treg ; \ obsolete ! : mtr ( addr op -- addr' ) .mov .treg ., .reg32 ; \ obsolete : mv1 ( addr op -- addr' ) *************** *** 481,488 **** : mli ( addr op -- addr' ) 1 to dis.size ! .sop" imul" 0x69 = ! IF r,r/m .imm16/32 ! ELSE r,r/m .imm8 ! THEN ; \ -------------------- Jumps and Calls -------------------- --- 479,483 ---- : mli ( addr op -- addr' ) 1 to dis.size ! .sop" imul" swap r,r/m ., bit1 if .imm8 else .imm16/32 then ; \ -------------------- Jumps and Calls -------------------- *************** *** 766,773 **** then ; ! : .btx(XXXN-NXXX) ( n -- ) bits3-4 z" bt btsbtrbtc" 3 .ss ; : gp8 ( addr op -- addr' ) ! drop count dup .btx(XXXN-NXXX) r/m16/32 .imm8 ; --- 761,768 ---- then ; ! : .btx ( n -- ) bits3-4 z" bt btsbtrbtc" 3 .ss ; : gp8 ( addr op -- addr' ) ! drop count dup .btx r/m16/32 .imm8 ; *************** *** 792,799 **** : sli ( addr op -- addr' ) sld .imm8 ; : sri ( addr op -- addr' ) srd .imm8 ; ! : slc ( addr op -- addr' ) sld ." , cl" ; ! : src ( addr op -- addr' ) srd ." , cl" ; ! : btx ( addr op -- addr' ) .btx(XXXN-NXXX) r/m,r ; : cxc ( addr op -- addr' ) .sop" cmpxchg" bit0 to dis.size r/m,r ; : xad ( addr op -- addr' ) .sop" xadd" bit0 to dis.size r/m,r ; --- 787,794 ---- : sli ( addr op -- addr' ) sld .imm8 ; : sri ( addr op -- addr' ) srd .imm8 ; ! : slc ( addr op -- addr' ) sld .,cl ; ! : src ( addr op -- addr' ) srd .,cl ; ! : btx ( addr op -- addr' ) .btx r/m,r ; : cxc ( addr op -- addr' ) .sop" cmpxchg" bit0 to dis.size r/m,r ; : xad ( addr op -- addr' ) .sop" xadd" bit0 to dis.size r/m,r ; *************** *** 864,873 **** : set ( adr op -- ) ! oper-col ." set" .cond opnd-col ! count r/m8 ; : cmv ( adr op -- ) ! oper-col ." cmov" .cond opnd-col ! r,r/m ; \ --------------------- MMX Operations ----------------- --- 859,868 ---- : set ( adr op -- ) ! oper-col ." set" .cond opnd-col count r/m8 ; ! : cmv ( adr op -- ) ! oper-col ." cmov" .cond opnd-col r,r/m ; ! \ --------------------- MMX Operations ----------------- *************** *** 879,883 **** : uph ( adr op -- adr' ) bits0-1 z" punpckhbwpunpckhwdpunpckhdq" 9 .ss r,r/m ; ! : .psx(XXNN-XXXX) ( op -- ) 0x30 and case --- 874,878 ---- : uph ( adr op -- adr' ) bits0-1 z" punpckhbwpunpckhwdpunpckhdq" 9 .ss r,r/m ; ! : .psx ( op -- ) 0x30 and case *************** *** 888,896 **** endcase ; ! : shx ( adr op -- adr' ) dup .psx(XXNN-XXXX) mmx-size r,r/m ; : gpa ( adr op -- adr' ) \ xx00-xxxx -> ??? ! >r count dup .psx(XXNN-XXXX) r> mmx-size .regm ., .imm8 ; : mpd ( adr op -- adr' ) --- 883,891 ---- endcase ; ! : shx ( adr op -- adr' ) dup .psx mmx-size r,r/m ; : gpa ( adr op -- adr' ) \ xx00-xxxx -> ??? ! >r count dup .psx r> mmx-size .regm ., .imm8 ; : mpd ( adr op -- adr' ) *************** *** 939,943 **** : ops 0x10 0 do ' , loop ; ! create op2-table2 \ 0 1 2 3 4 5 6 7 8 9 A B C D E F --- 934,938 ---- : ops 0x10 0 do ' , loop ; ! create op2-table \ 0 1 2 3 4 5 6 7 8 9 A B C D E F *************** *** 968,972 **** drop count dup dup 0x70 and 0x50 0x80 within to dis.mmx-reg? ! cells op2-table2 + perform 0 to dis.mmx-reg? ; --- 963,967 ---- drop count dup dup 0x70 and 0x50 0x80 within to dis.mmx-reg? ! cells op2-table + perform 0 to dis.mmx-reg? ; |
|
From: Jos v.d.V. <jo...@us...> - 2007-05-01 17:17:30
|
Update of /cvsroot/win32forth/win32forth-stc/demos In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv14462 Added Files: WINHELLO.F Log Message: Jos: I could not resist to test this demo! It is great that we can do windows in the ST-version! --- NEW FILE: WINHELLO.F --- \ WINHELLO.F Simple Windows Hello World by Tom Zimmer \ See also HELLO.F for a similar example that doesn't use objects false value CreateTurnkey? \ set to TRUE if you want to create a turnkey application needs window.f \ Define an object "HelloWindow" that is a super object of class "Window" :Object HelloWindow <Super Window int counter \ a local variable for a counter :M StartSize: ( -- w h ) \ the screen origin of our window 170 90 ;M :M StartPos: ( -- x y ) \ the width and height of our window 200 100 ;M :M WindowTitle: ( -- Zstring ) \ window caption z" Hello World" ;M :M On_EraseBackground: ( hwnd msg wparam lparam -- res ) \ let the On_Paint: Method redraw the background 4drop 0 ;M :M On_Paint: { \ temp$ -- } \ all window refreshing is done by On_Paint: \ draw background only if needed ps_fErase if \ cr ." erase background" ps_left ps_top ps_right ps_bottom black FillArea: dc then \ check if our drawing area is visible or not 0 0 170 90 SetRect: wRect AddrOf: wRect GetHandle: dc call RectVisible if \ cr ." visible" \ let's draw... black SetBkColor: dc ltgreen SetTextColor: dc MAXSTRING LocalAlloc: temp$ s" Repainted " temp$ place counter (.) temp$ +place s" times" temp$ +place 20 ( x ) 50 ( y ) temp$ count TextOut: dc 20 ( x ) 20 ( y ) s" Hello World" TextOut: dc \ else cr ." invisible" then ;M :M Paint: ( -- ) \ Note: The Paint: method of the window class invalidates the \ complete client rectangle. Since we only draw in a smal part \ of the window only the the part of the window in whitch we \ are going to draw is marked as invalid. 0 0 170 90 SetRect: wRect 1 AddrOf: wRect hWnd Call InvalidateRect ?win-error ;M :M WM_TIMER ( h m w l -- res ) \ handle the WM_TIMER events 1 +to counter \ bump the counter Paint: self \ refresh the window 0 ;M :M On_Init: ( -- ) \ things to do at the start of window creation On_Init: super \ do anything superclass needs 0 to counter \ then initialize counter is zero 0 200 1 hWnd Call SetTimer drop \ init timer to a 200 ms rate ;M :M On_Done: ( -- ) \ things to do before program termination 1 hWnd Call KillTimer drop \ destroy the timer, we are done On_Done: super \ then do things superclass needs CreateTurnkey? if bye then \ terminate application ;M ;Object CreateTurnkey? [IF] : DEMO ( -- ) \ start running the demo program Start: HelloWindow ; ' DEMO turnkey WinHello \ create WinHello.exe [ELSE] : DEMO ( -- ) \ start running the demo program Start: HelloWindow ; : UNDEMO ( -- ) \ close the demo window Close: HelloWindow ; cr .( Type: DEMO to start, and: UNDEMO to stop) cr [THEN] demo |
|
From: Jos v.d.V. <jo...@us...> - 2007-05-01 17:15:37
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13545 Added Files: FONTS.F Log Message: Needed for the demo. --- NEW FILE: FONTS.F --- \ $Id: FONTS.F,v 1.1 2007/05/01 17:15:33 jos_ven Exp $ \ FONTS.F Font Class and Methods \ 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 Create: ( -- ) Create: super drop ;M :M Delete: ( -- ) Destroy: super ;M :M Handle: ( -- hFont ) GetHandle: super ;M ;class |
|
From: George H. <geo...@us...> - 2007-05-01 07:41:59
|
Update of /cvsroot/win32forth/win32forth-stc/src/gdi In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv12728/win32forth-stc/src/gdi Modified Files: gdiBase.f Log Message: gah:Tidied up loading message order plus additions and bugfixes to class.f Index: gdiBase.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/gdi/gdiBase.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** gdiBase.f 28 Apr 2007 10:18:57 -0000 1.1 --- gdiBase.f 1 May 2007 07:41:55 -0000 1.2 *************** *** 1,2 **** --- 1,4 ---- + \ $Id$ + \ *D doc\classes\ \ *! gdiBase *************** *** 164,190 **** begin dup while dup cell+ @ ! method execute @ repeat drop ; - \ : init-gdi-objects ( -- ) \ clear all handles - \ [getmethod] ZeroHandle: GdiObject do-objects ; - - \ [getmethod] not yet implemented - - : init-gdi-object ( obj -- ) - ZeroHandle: GdiObject ; - : init-gdi-objects ( -- ) \ clear all handles ! ['] init-gdi-object do-objects ; :M destroy-gdi-objects: ( -- ) \ destory this object 0 SetHandle: self ;M - : destroy-gdi-object ( obj -- ) \ destroy a GDI object - destroy-gdi-objects: GdiObject ; - : destroy-gdi-objects ( -- ) \ destroy all GDI objects ! ['] destroy-gdi-object do-objects ; initialization-chain chain-add init-gdi-objects --- 166,181 ---- begin dup while dup cell+ @ ! method Methodexecute @ repeat drop ; : init-gdi-objects ( -- ) \ clear all handles ! [getmethod] ZeroHandle: GdiObject do-objects ; :M destroy-gdi-objects: ( -- ) \ destory this object 0 SetHandle: self ;M : destroy-gdi-objects ( -- ) \ destroy all GDI objects ! [getmethod] destroy-gdi-objects: GdiObject do-objects ; initialization-chain chain-add init-gdi-objects |
|
From: George H. <geo...@us...> - 2007-05-01 07:41:59
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv12728/win32forth-stc/src Modified Files: Class.f Dc.f GENERIC.F Window.f Log Message: gah:Tidied up loading message order plus additions and bugfixes to class.f Index: Window.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/Window.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Window.f 30 Apr 2007 07:49:26 -0000 1.1 --- Window.f 1 May 2007 07:41:55 -0000 1.2 *************** *** 6,17 **** \ *S Glossary cr .( Loading Window Class...) \ Window class - only forth also definitions - - require generic.f - in-application --- 6,15 ---- \ *S Glossary + require generic.f + cr .( Loading Window Class...) \ Window class in-application *************** *** 244,248 **** 3 pick ( msg ) over obj>class MFA ((findm)) if sp0 @ >r sp@ 4 cells+ sp0 ! ! dup>r catchm ?dup if r@ WndProcError --- 242,246 ---- 3 pick ( msg ) over obj>class MFA ((findm)) if sp0 @ >r sp@ 4 cells+ sp0 ! ! dup>r MethodCatch ?dup if r@ WndProcError *************** *** 932,934 **** --- 930,934 ---- NULL call LoadImage ; + in-previous + \ *Z Index: Dc.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/Dc.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Dc.f 30 Apr 2007 07:49:26 -0000 1.1 --- Dc.f 1 May 2007 07:41:55 -0000 1.2 *************** *** 1,4 **** --- 1,10 ---- \ $Id$ + needs utils.f + needs gdi/gdiDC.f + needs colors.f + needs PrintSupport.f + needs Fonts.f + cr .( Loading Device Context and Printing...) *************** *** 13,22 **** in-application - needs utils.f - needs gdi/gdiDC.f - needs colors.f - needs PrintSupport.f - needs Fonts.f - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ --- 19,22 ---- Index: GENERIC.F =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/GENERIC.F,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** GENERIC.F 30 Apr 2007 07:49:26 -0000 1.1 --- GENERIC.F 1 May 2007 07:41:55 -0000 1.2 *************** *** 34,43 **** \ *S Glossary - cr .( Loading Generic Window...) - - only forth also definitions decimal - Needs Dc.f in-application --- 34,41 ---- \ *S Glossary Needs Dc.f + cr .( Loading Generic Window...) + in-application Index: Class.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/Class.f,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** Class.f 30 Apr 2007 07:49:26 -0000 1.4 --- Class.f 1 May 2007 07:41:55 -0000 1.5 *************** *** 1377,1391 **** \ -------------------------------------------------------------------- ! : executem ( i*x ^obj methodXT -- j*x ) ! \ *G Version of execute for ubjects and methods. (comp-only) compilation> drop postpone swap postpone PushOP postpone OP postpone ! postpone execute postpone PopOP ; ! : catchm ( i*x ^obj methodXT -- j*x 0 | i*x n ) ! \ *G Version of catch for ubjects and methods. (comp-only) compilation> drop postpone swap postpone PushOP postpone OP postpone ! ! postpone catch postpone PopOP ; \ ==================================================================== --- 1377,1392 ---- \ -------------------------------------------------------------------- ! : MethodExecute ( i*x ^obj methodXT -- j*x ) ! \ *G Version of execute for objects and methods. (comp-only) compilation> drop postpone swap postpone PushOP postpone OP postpone ! postpone execute postpone PopOP ; ! : MethodCatch ( i*x ^obj methodXT -- j*x 0 | i*x ^obj n ) ! \ *G Version of catch for objects and methods. (comp-only) compilation> drop postpone swap postpone PushOP postpone OP postpone ! ! postpone catch postpone dup postpone if postpone self postpone swap ! postpone then postpone PopOP ; \ ==================================================================== *************** *** 1607,1611 **** RECTANGLE temprect \ a sample rectangle object, used by the system sometimes ! \s \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ display all classes in the system --- 1608,1612 ---- RECTANGLE temprect \ a sample rectangle object, used by the system sometimes ! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ display all classes in the system *************** *** 1613,1617 **** IN-SYSTEM ! : .CLASSES ( -- ) \ W32F Class \ *G Display all classes in the system. --- 1614,1618 ---- IN-SYSTEM ! (( : .CLASSES ( -- ) \ W32F Class \ *G Display all classes in the system. *************** *** 1631,1635 **** @ dup 0= UNTIL drop ; ! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ return xt of method --- 1632,1636 ---- @ dup 0= UNTIL drop ; ! )) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ return xt of method *************** *** 1643,1650 **** TRUE to get-reference? \ tell do_message to return method depth >r ! execute to m0cfa \ execute do_message ! depth r> < ! if 0 \ if it was a class, object is NULL ! then to obj-save m0cfa ; : [GetMethod] ( compiling:- -<method: object>- -- ) ( runtime:- -- m0cfa ) \ W32F Class --- 1644,1649 ---- TRUE to get-reference? \ tell do_message to return method depth >r ! execute \ execute do_message ! depth r> > if nip then ; : [GetMethod] ( compiling:- -<method: object>- -- ) ( runtime:- -- m0cfa ) \ W32F Class |
|
From: George H. <geo...@us...> - 2007-05-01 07:32:58
|
Update of /cvsroot/win32forth/win32forth/src/gdi In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv9229/win32forth/src/gdi Modified Files: gdiBase.f Log Message: gah:Modified to maintain consistency with STC Index: gdiBase.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/gdi/gdiBase.f,v retrieving revision 1.7 retrieving revision 1.8 diff -C2 -d -r1.7 -r1.8 *** gdiBase.f 8 Jan 2006 09:28:08 -0000 1.7 --- gdiBase.f 1 May 2007 07:32:55 -0000 1.8 *************** *** 1,2 **** --- 1,4 ---- + \ $Id$ + \ *D doc\classes\ \ *! gdiBase *************** *** 164,168 **** begin dup while dup cell+ @ ! method execute @ repeat drop ; --- 166,170 ---- begin dup while dup cell+ @ ! method Methodexecute @ repeat drop ; *************** *** 190,197 **** 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 ; : GetGdiObjectHandle { GdiObject -- handle } \ w32f --- 192,199 ---- begin dup while dup cell+ @ r@ = \ match this gdi object? ! if drop rdrop true EXIT \ leave test, passed then @ repeat drop ! rdrop false ; : GetGdiObjectHandle { GdiObject -- handle } \ w32f |
|
From: George H. <geo...@us...> - 2007-05-01 07:32:58
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv9229/win32forth/src Modified Files: Class.f Window.f Log Message: gah:Modified to maintain consistency with STC Index: Window.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Window.f,v retrieving revision 1.17 retrieving revision 1.18 diff -C2 -d -r1.17 -r1.18 *** Window.f 8 Nov 2006 11:11:24 -0000 1.17 --- Window.f 1 May 2007 07:32:55 -0000 1.18 *************** *** 6,9 **** --- 6,11 ---- \ *S Glossary + require generic.f + cr .( Loading Window Class...) *************** *** 245,249 **** ?dup if r@ WndProcError ! then r>drop r> sp0 ! else \ -- a1 \ the object address --- 247,251 ---- ?dup if r@ WndProcError ! then rdrop r> sp0 ! else \ -- a1 \ the object address Index: Class.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Class.f,v retrieving revision 1.29 retrieving revision 1.30 diff -C2 -d -r1.29 -r1.30 *** Class.f 30 Apr 2007 08:27:44 -0000 1.29 --- Class.f 1 May 2007 07:32:55 -0000 1.30 *************** *** 1206,1209 **** --- 1206,1216 ---- IF idxBase 2 - w@ ( #elems ) * + CELL+ THEN ; + \ -------------------------------------------------------------------- + \ ------------- Support for windows procedures etc ------------------- + \ -------------------------------------------------------------------- + + ' execute alias Methodexecute + ' catch alias Methodcatch + \ ==================================================================== \ Support for 2 dimensional arrays |
|
From: George H. <geo...@us...> - 2007-04-30 11:02:07
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv12487/win32forth-stc/src Added Files: PrintSupport.f Log Message: gah:Added Printsupport.f --- NEW FILE: PrintSupport.f --- \ PrintSupport Rod Oakford June 28th, 2004 \ for version 6.09.07 removed rel>abs, added PROCs cr .( Loading Print Support...) WINLIBRARY COMDLG32.DLL 1 PROC PrintDlg 1 PROC PageSetupDlg \ WINLIBRARY GDI32.DLL 2 PROC StartDoc 1 PROC EndDoc 1 PROC StartPage 1 PROC EndPage 1 PROC DeleteDC 2 PROC GetDeviceCaps \ WINLIBRARY KERNEL32.DLL 1 PROC GlobalLock 1 PROC GlobalUnlock \ WINLIBRARY USER32.dll 4 PROC MessageBox Create PSD 21 cells , 20 cells allot PSD cell+ Constant hOwner PSD 4 cells+ Constant PSDFlags PSD 5 cells+ Constant ptPaperSize PSD 7 cells+ Constant rtMinMargin PSD 11 cells+ Constant rtMargin Create PD 16 cells 2 + , 16 cells allot PD cell+ Constant hwndOwner PD 2 cells+ Constant hDevMode PD 3 cells+ Constant hDevNames PD 4 cells+ Constant hDC PD 5 cells+ Constant PDFlags PD 6 cells+ Constant nFromPage 1 nFromPage w! PD 26 + Constant nToPage 999 nToPage w! PD 7 cells+ Constant nMinPage 1 nMinPage w! PD 30 + Constant nMaxPage 999 nMaxPage w! PD 8 cells+ Constant nCopies Create DI 5 cells , 4 cells allot DI cell+ Constant DocName 0 value Job : PageSetupDlg ( -- f ) \ display the new Page Setup dialog PSD Call PageSetupDlg hOwner hwndOwner 12 move \ copy hwndOwner, hDevMode ; \ and hDevNames to PD : PrintDlg ( -- f ) \ display the Print dialog PD Call PrintDlg hwndOwner hOwner 12 move \ copy hwndOwner, hDevMode ; \ and hDevNames to PSD \ Win2K: unless hwndOwner is 0, PrintDlg displays \ the new Print Property Sheet instead. : Print-close ( -- ) hDC @ Call DeleteDC drop 0 hDC ! ; \ close the printer : Print-init2 ( Bitmapped Flags Topage -- PrintDC ) 1 max nToPage w! nToPage w@ nFromPage w@ < IF 1 nFromPage w! THEN PD_RETURNDC or PDFlags ! PrintDlg IF hDC @ swap IF \ Bitmapped RASTERCAPS hDC @ Call GetDeviceCaps RC_BITBLT and not IF MB_OK Z" Device Error" Z" Printer cannot display bitmaps." 0 Call MessageBox drop Print-close drop 0 EXIT THEN THEN DocName 16 erase \ document name can be changed before Print-Start Z" Document" DocName ! ELSE drop 0 THEN ; \ initialize the printer, return DC \ unless the default values will do set nFromPage, \ nMinPage and nMaxPage before calling Print-init2 : Print-init ( -- PrintDC ) True \ selected printer must be able to display bitmaps [ PD_HIDEPRINTTOFILE PD_PAGENUMS or PD_NOSELECTION or PD_USEDEVMODECOPIES or ] literal nToPage w@ Print-init2 ; \ initialize the printer, return DC \ for backward compatability : Print-setup ( window_handle -- PrintDC ) hwndOwner ! False PD_PRINTSETUP nToPage w@ Print-init2 ; \ display the Print Setup dialog, return DC \ better to use PageSetupDlg having set up PSD : Auto-print-init ( -- PrintDC ) hDevMode 8 erase \ set hDevMode and hDevNames to null True \ default printer must be able to display bitmaps PD_RETURNDEFAULT nToPage w@ Print-init2 ; \ initialize the default printer, return DC : Print-start ( -- ) DI hDC @ Call StartDoc to Job \ <=0 means error hDC @ Call StartPage drop \ and job won't print ; \ start printing a new page for new doc : Start-page ( -- ) hDC @ Call StartPage drop ; \ start a new printed page : End-page ( -- ) hDC @ Call EndPage drop ; \ finish a printed page : Print-page ( -- ) End-Page Start-Page ; \ finish current page start new page : Print-end ( -- ) hDC @ Call EndPage drop hDC @ Call EndDoc drop ; \ finish printing page and doc : Get-frompage ( -- n1 ) PDFlags @ PD_PAGENUMS and IF nFromPage ELSE nMinPage THEN w@ ; : Get-topage ( -- n1 ) PDFlags @ PD_PAGENUMS and IF nToPage ELSE nMaxPage THEN w@ ; : Get-copies ( -- n ) nCopies w@ ; : Print-flags ( -- flag ) PDFlags @ ; \ flags returned depend on user selection : DefaultPrinter ( -- ) hDevMode 8 erase \ set hDevMode and hDevNames to null PD_RETURNDEFAULT PDFlags ! PrintDlg drop ; \ get hDevMode and hDevNames for the default printer : LockDevMode ( -- a ) hDevMode @ Call GlobalLock ; : UnlockDevMode ( -- ) hDevMode @ Call GlobalUnlock drop ; : Quality-print ( -- n ) LockDevMode dup IF 58 + w@ UnlockDevMode THEN ; \ return the print quality, usually in DPI, dmPrintQuality : Paper-size ( -- w h ) LockDevMode dup dup IF drop 48 + @ word-split swap UnlockDevMode THEN ; \ return the paper size dmPaperWidth and dmPaperLength : Print-Orientation ( f -- PrintDC ) IF DMORIENT_LANDSCAPE ELSE DMORIENT_PORTRAIT THEN Auto-print-init swap LockDevMode ?dup IF 44 + w! UnlockDevMode ELSE drop THEN \ set dmOrientation ; \ initialize the default printer and set the orientation |
|
From: George H. <geo...@us...> - 2007-04-30 08:27:48
|
Update of /cvsroot/win32forth/win32forth/src/gdi In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv15418/win32forth/src/gdi Modified Files: gdiStruct.f Log Message: gah:Tidied up vocabularies in class.f and added dependencies to dc.f and gdi\\gdistruct.f Index: gdiStruct.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/gdi/gdiStruct.f,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** gdiStruct.f 8 Jan 2006 09:28:08 -0000 1.4 --- gdiStruct.f 30 Apr 2007 08:27:45 -0000 1.5 *************** *** 8,11 **** --- 8,13 ---- cr .( Loading GDI class library - Structs...) + needs class.f + WinLibrary COMDLG32.DLL |
|
From: George H. <geo...@us...> - 2007-04-30 08:27:48
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv15418/win32forth/src Modified Files: Class.f Dc.f Log Message: gah:Tidied up vocabularies in class.f and added dependencies to dc.f and gdi\\gdistruct.f Index: Dc.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Dc.f,v retrieving revision 1.12 retrieving revision 1.13 diff -C2 -d -r1.12 -r1.13 *** Dc.f 19 Nov 2005 11:13:09 -0000 1.12 --- Dc.f 30 Apr 2007 08:27:44 -0000 1.13 *************** *** 14,17 **** --- 14,20 ---- needs gdi/gdiDC.f + needs colors.f + needs PrintSupport.f + needs Fonts.f \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ Index: Class.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Class.f,v retrieving revision 1.28 retrieving revision 1.29 diff -C2 -d -r1.28 -r1.29 *** Class.f 16 Apr 2007 09:07:23 -0000 1.28 --- Class.f 30 Apr 2007 08:27:44 -0000 1.29 *************** *** 602,606 **** module ! classes also definitions internal --- 602,606 ---- module ! classes definitions internal *************** *** 1234,1238 **** module ! forth definitions also hidden : +range ['] ?range is ?idx ; +range --- 1234,1238 ---- module ! previous definitions also classes also hidden : +range ['] ?range is ?idx ; +range *************** *** 1241,1245 **** initialization-chain chain-add +range ! classes : Dimension ( Rows Cols -- Size ) --- 1241,1245 ---- initialization-chain chain-add +range ! previous : Dimension ( Rows Cols -- Size ) *************** *** 1248,1252 **** \ ** For dynamic object DIMENSION applies to the next 2 dimensional array in the same task. ColDim ! RowDim ! ColDim RowDim * ; ! previous : Dispose ( addr -- ) --- 1248,1252 ---- \ ** For dynamic object DIMENSION applies to the next 2 dimensional array in the same task. ColDim ! RowDim ! ColDim RowDim * ; ! : Dispose ( addr -- ) *************** *** 1275,1279 **** in-system ! :Class ClassRoot ' classes >Class classes inherit \ *G Use this class if you have no ivars in your class. \ ** It will trap undefined methods that might slip through otherwise. --- 1275,1279 ---- in-system ! :Class ClassRoot ' classes >Class inherit \ *G Use this class if you have no ivars in your class. \ ** It will trap undefined methods that might slip through otherwise. *************** *** 1306,1309 **** --- 1306,1311 ---- ;Class + previous also + in-system *************** *** 1351,1354 **** --- 1353,1359 ---- ;Class \ *G End of class + + also classes + unres-methods unres-len erase *************** *** 1356,1359 **** --- 1361,1366 ---- \ link into definition completion + previous + \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Define data type class for strings *************** *** 1447,1451 **** \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! classes also hidden also : GetMethod { \ m0cfa -- -<method: object>- m0cfa } \ W32F Class --- 1454,1458 ---- \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ! also classes also hidden : GetMethod { \ m0cfa -- -<method: object>- m0cfa } \ W32F Class *************** *** 1465,1469 **** Postpone Literal ; Immediate IN-APPLICATION - only forth also definitions --- 1472,1477 ---- Postpone Literal ; Immediate + previous previous + IN-APPLICATION |
|
From: George H. <geo...@us...> - 2007-04-30 07:49:32
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv32749/win32forth-stc/src Modified Files: Class.f primutil.f Added Files: COLORS.F Dc.f GENERIC.F Menu.f Utils.f Window.f Log Message: gah:Added the rest of the gdi functions and some other class files updated primutil.f with extra utilities needed for GUI and bugfixes/extensions to class.f --- NEW FILE: GENERIC.F --- \ $Id: GENERIC.F,v 1.1 2007/04/30 07:49:26 georgeahubert Exp $ \ *D doc\classes\ \ *! Generic \ *T Generic-Window -- Base class for all window objects. \ *P Generic-Window is the base class for all window objects. This class \ ** contains a single ivar, hWnd, that is the (MS Windows) handle for the \ ** window. This class encapsulates all the Win32 API calls that specify a \ ** window handle. There will be the following subclasses of Generic-Window: \ *W <ul> \ *W <li><a href="Window.htm">Window</a> Adds a device context and the ablility to display text and graphics output.</li> \ *W <li><a href="Dialog.htm">Dialog</a> Support for dialog boxes</li> \ *W <li><a href="Control.htm">Control</a> Adds support for the standard Win32 controls with subclassing.</li> \ *W </ul> \ *P Since Generic-Window is a generic class it should not be used to create \ ** any instances. \n \ ** The Global Rectangle objects wRect and WndRect ( originally \ ** defined in Window.f ) have been replaced by a Rectangle IVAR WinRect so that \ ** Windows in different threads don't interfere with each other's drawing \ ** operations. \n \ ** For backwards compatibility wRect is defined as an int which is set \ ** to the address of WinRect by the ClassInit: method ( and WndRect is defined as \ ** an alias of wRect in Window.f. Also ) however WinRect should be used in new \ ** code since it uses early binding. ClientRect in class EditControl ( in Controls.f ) \ ** is also defined as an alias of wRect for compatibility. \n \ ** We also provide wRect as an alias of TempRect for compatibility. \n \ ** Temporarily added new generic class Dialog&Control and moved some code into it and \ ** duplicated the same code in Class Window so that Ivar offsets in Class Window are \ ** the same for temporary compatibility. \ *S Glossary cr .( Loading Generic Window...) only forth also definitions decimal Needs Dc.f in-application \ Linked list, to hold all dictionary window objects. VARIABLE windows-link windows-link OFF \ Linked list, to hold all modeless dialog, Frame window and MDI child window objects \ that respond to dialog messages. VARIABLE dialog-link dialog-link OFF \ Normally wRect is called by methods and : definitions inside generic-window, however the \ original global object is used by Lib\RegistryWindowPos.f so we define it \ as an alias for backward compatibility. ' TempRect Alias wRect in-system :CLASS Generic-Window <Super Object \ *G Base class for all window objects. \ Macros for backward compatibility : wRect.addrof s" addrof: winrect" evaluate ; immediate : wRect.left s" left: winrect" evaluate ; immediate : wRect.right s" right: winrect" evaluate ; immediate : wRect.top s" top: winrect" evaluate ; immediate : wRect.bottom s" bottom: winrect" evaluate ; immediate synonym TempRect.addrof wRect.addrof synonym TempRect.left wRect.left synonym TempRect.right wRect.right synonym TempRect.top wRect.top synonym TempRect.bottom wRect.bottom in-application \ ----------------------------------------------------------------- \ *N Instance Variables \ ----------------------------------------------------------------- \ WARNING: DO NOT ADD ANY INSTANCE VARIABLES TO THIS CLASS BEFORE HWND \ HWND MUST BE THE FIRST IVAR. THIS IS ESSENTIAL TO THE \ WINDOW PROCEDURE OF CLASS WINDOW AND THE SUBCLASSING TECHNIQUE \ USED BY CLASS CONTROL. int hWnd \ *G handle to Win32 window object \ ----------------------------------------------------------------- \ ----------------------------------------------------------------- in-system : static-window? ( -- f1 ) \ is this a static window self adp in-space? self sdp in-space? or ; : link-window ( -- ) static-window? \ only link in static windows if windows-link link, \ link into list self , then ; : trim-windows ( nfa -- nfa ) \ for forgetting dup windows-link full-trim ; forget-chain chain-add trim-windows : trim-dialogs ( nfa -- nfa ) dup Dialog-link full-trim ; forget-chain chain-add trim-dialogs in-application : SendMessage:Self ( lParam wParam message -- result ) \ *G Send a windows message to our self. hWnd call SendMessage ; : SendMessage:SelfDrop ( lParam wParam message -- ) \ *G Send a windows message to our self and discard the result. SendMessage:Self drop ; \ ----------------------------------------------------------------- \ *N Methods \ ----------------------------------------------------------------- :M Classinit: ( -- ) \ *G Initialise the class. ClassInit: super 0 to hWnd turnkeyed? 0= \ only dynamic windows can be used in a \in-system-ok if link-window then \ turnkeyed application so skip linking ;M :M GetHandle: ( -- hWnd ) \ *G Get the window handle. hWnd ;M :M PutHandle: ( hWnd -- ) \ *G Set the window handle. Normally handled by the system. to hWnd ;M :M ZeroWindow: ( -- ) \ *G Clear the window handle. Normally handled by the system. At start-up all window \ ** objects are zeroed automatically. 0 to hWnd ;M :M DestroyWindow: ( -- ) \ *G Destroy the window. The handle is always zero after executing this method. In a \ ** mult-tasking application this method causes an error if executed by a task that \ ** didn't create the window. hWnd if hWnd Call DestroyWindow ?win-error 0 to hWnd then ;M :M Close: ( -- ) \ *G Close the window. DestroyWindow: self ;M :M Paint: ( -- ) \ *G Force window repaint. A WM_PAINT message is posted to the message queue. hWnd if 1 0 hWnd Call InvalidateRect ?win-error then ;M :M SetRedraw: ( f -- ) \ *G Set the redraw state of the window. \ *P \i f \d Specifies the redraw state. If this parameter is TRUE, the \ ** content can be redrawn after a change. If this parameter is FALSE, \ ** the content cannot be redrawn after a change. 0 swap WM_SETREDRAW hWnd call SendMessage drop ;M :M Show: ( state -- ) \ *G The ShowWindow function sets the specified window's show state. \n \ ** Possible values for state are: \ *L \ *| SW_FORCEMINIMIZE | Windows 2000: Minimizes a window, even if the thread that owns the window is hung. This flag should only be used when minimizing windows from a different thread. | \ *| SW_HIDE | Hides the window and activates another window. | \ *| SW_MAXIMIZE | Maximizes the specified window. | \ *| SW_MINIMIZE | Minimizes the specified window and activates the next top-level window in the Z order. | \ *| SW_RESTORE | Activates and displays the window. If the window is minimized or maximized, the system restores it to its original size and position. An application should specify this flag when restoring a minimized window. | \ *| SW_SHOW | Activates the window and displays it in its current size and position. | \ *| SW_SHOWDEFAULT | Sets the show state based on the SW_ value specified in the STARTUPINFO structure passed to the CreateProcess function by the program that started the application. | \ *| SW_SHOWMAXIMIZED | Activates the window and displays it as a maximized window. | \ *| SW_SHOWMINIMIZED | Activates the window and displays it as a minimized window. | \ *| SW_SHOWMINNOACTIVE | Displays the window as a minimized window. This value is similar to SW_SHOWMINIMIZED, except the window is not activated. | \ *| SW_SHOWNA | Displays the window in its current size and position. This value is similar to SW_SHOW, except the window is not activated. | \ *| SW_SHOWNOACTIVATE | Displays a window in its most recent size and position. This value is similar to SW_SHOWNORMAL, except the window is not actived. | \ *| SW_SHOWNORMAL | Activates and displays a window. If the window is minimized or maximized, the system restores it to its original size and position. An application should specify this flag when displaying the window for the first time. | \ *P If the window belongs to a different task or application the WM_SHOW is posted to the \ ** the message queue to prevent the current task hanging. If the window belongs to the \ ** current task the message is sent. hWnd if 0 hWnd call GetWindowThreadProcessId call GetCurrentThreadId = if hWnd Call ShowWindow else hWnd call ShowWindowAsync then then drop ;M :M GDIFlush: ( -- ) \ *G The GdiFlush function flushes the calling thread's current batch. Call GdiFlush ?win-error ;M :M Update: ( -- ) \ *G The UpdateWindow function updates the client area of the window by sending \ ** a WM_PAINT message to the window if the window's update region is not empty. The \ ** function sends a WM_PAINT message directly to the window procedure of the window, \ ** bypassing the application queue. If the update region is empty, no message is sent. hWnd if hWnd Call UpdateWindow ?win-error then ;M :M Scroll: { x y -- } \ *G The ScrollWindow function scrolls the contents of the specified window's client area. hWnd if 0 0 y x hWnd Call ScrollWindow drop then ;M :M Move: { x y w h -- } \ *G The MoveWindow function changes the position and dimensions of window. \ ** For a top-level window, the position and dimensions are relative to the upper-left corner \ ** of the screen. For a child window, they are relative to the upper-left corner of the parent \ ** window's client area. hWnd if 1 ( repaint flag ) h w y x hWnd Call MoveWindow ?win-error then ;M :M SetWindowPos: { x y -- } \ *G The SetWindowPos function changes the position of a child, pop-up, or top-level window. \n \ ** X Specifies the new position of the left side of the window, in client coordinates. \n \ ** Y Specifies the new position of the top of the window, in client coordinates. hWnd if [ SWP_NOSIZE SWP_SHOWWINDOW or SWP_NOZORDER or ] literal 0 0 \ no size specified y x 0 \ insert parameter not used hWnd Call SetWindowPos ?win-error \ April 27th, 1998 - 9:14 tjz removed, reported by Bruno Gauthier \ else 2drop then ;M (( :M GetWindowRect: ( -- left top right bottom ) hWnd if EraseRect: WinRect AddrOf: WinRect hWnd Call GetWindowRect ?win-error Left: WinRect Top: WinRect Right: WinRect Bottom: WinRect else 0 0 0 0 then ;M )) :M SetMenu: ( MenuHandle -- ) \ *G The SetMenu function assigns a new menu to the window. \ ** If MenuHandle is NULL, the window's current menu is removed. hWnd -if Call SetMenu ?win-error else 2drop then ;M :M SetText: { addr len \ text$ -- } \ *G The SetWindowText function changes the text of the window's title bar (if it has one). \ ** If the window is a control, the text of the control is changed. hWnd if MAXSTRING localAlloc: text$ addr len text$ place text$ +NULL text$ 1+ hWnd Call SetWindowText ?win-error then ;M maxstring newuser gettext$ :M GetText: ( -- addr len ) \ *G The GetWindowText function copies the text of the window's title bar (if it has one) \ ** into a buffer. If the window is a control, the text of the control is copied. gettext$ hWnd -if over MAXCOUNTED 3reverse Call GetWindowText then ;M : (SetTextAlign) ( flag hwnd -- ) dup>r Call GetDC >r ( flag ) case 1 of [ TA_RIGHT TA_UPDATECP or ] literal endof 2 of [ TA_CENTER TA_UPDATECP or ] literal endof [ TA_LEFT TA_UPDATECP or ] literal swap endcase r@ Call SetTextAlign r> r> Call ReleaseDC 2drop ; :M SetTextAlign: ( flag -- ) \ *G Set the text-alignment for the window. \n \ ** The current position is updated after each text output call. \ ** The current position is used as the reference point. \ ** Possible values for flag are: \ *L \ *| 0 | The reference point will be on the left edge of the bounding rectangle. | \ *| 1 | The reference point will be on the right edge of the bounding rectangle. | \ *| 2 | The reference point will be aligned horizontally with the center of the bounding rectangle. | hwnd (SetTextAlign) ;M :M GetDC: ( -- hdc ) \ *G The GetDC function retrieves a handle to a display device context (DC) \ ** for the client area of the window. \n \ ** You have to call ReleaseDC when the DC isn't needed any longer. hWnd Call GetDC ;M :M GetWindowDC: ( -- hdc ) \ *G The GetWindowDC function 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. \n \ ** GetWindowDC assigns default attributes to the window device context each time it \ ** retrieves the device context. Previous attributes are lost. \n \ ** You have to call ReleaseDC when the DC isn't needed any longer. hWnd Call GetWindowDC ;M :M ReleaseDC: ( hdc -- ) \ *G The ReleaseDC function releases the device context (DC) of the window. \n \ ** Call only after GetDC or GetWindowDC. hWnd Call ReleaseDC ?win-error ;M :M BeginPaint: ( ps -- hdc ) \ *G The BeginPaint function prepares the window for painting and fills a \ ** PAINTSTRUCT (ps) structure with information about the painting. hWnd Call BeginPaint ;M :M EndPaint: ( ps -- ) \ *G The EndPaint function marks the end of painting in the window. This function is \ ** required for each call to the BeginPaint function, but only after painting is complete. hWnd Call EndPaint drop ;M :M GetClientRect: ( rect -- ) \ *G The GetClientRect function retrieves the coordinates of the window's client area. The \ ** client coordinates specify the upper-left and lower-right corners of the client area. \ ** Because client coordinates are relative to the upper-left corner of a window's client \ ** area, the coordinates of the upper-left corner are (0,0). hWnd Call GetClientRect ?win-error ;M :M GetWindowLong: ( index -- value ) \ *G The GetWindowLong function retrieves information about the window. The function \ ** also retrieves the 32-bit (long) value at the specified offset into the extra \ ** window memory. \n \ ** Index Specifies the zero-based offset to the value to be retrieved. Valid values are \ ** in the range zero through the number of bytes of extra window memory, minus four; for \ ** example, if you specified 12 or more bytes of extra memory, a value of 8 would be an \ ** index to the third 32-bit integer. To retrieve any other value, specify one of the \ ** following values. \ *L \ *| GWL_EXSTYLE | Retrieves the extended window styles. For more information, see CreateWindowEx. | \ *| GWL_STYLE | Retrieves the window styles. | \ *| GWL_WNDPROC | Retrieves the address of the window procedure, or a handle representing the address of the window procedure. You must use the CallWindowProc function to call the window procedure. | \ *| GWL_HINSTANCE | Retrieves a handle to the application instance. | \ *| GWL_HWNDPARENT | Retrieves a handle to the parent window, if any. | \ *| GWL_ID | Retrieves the identifier of the window. | \ *| GWL_USERDATA | Retrieves the 32-bit value associated with the window. Each window has a corresponding 32-bit value intended for use by the application that created the window. This value is initially zero. | hWnd Call GetWindowLong ;M :M SetWindowLong: ( value index -- oldval ) \ *G The SetWindowLong function changes an attribute of the window. The function also sets the \ ** 32-bit (long) value at the specified offset into the extra window memory. \ *L \ *| GWL_EXSTYLE | Sets a new extended window style. For more information, see CreateWindowEx. | \ *| GWL_STYLE | Sets a new window style. | \ *| GWL_WNDPROC | Sets a new address for the window procedure. Windows NT/2000: You cannot change this attribute if the window does not belong to the same process as the calling thread. | \ *| GWL_HINSTANCE | Sets a new application instance handle. | \ *| GWL_ID | Sets a new identifier of the window. | \ *| GWL_USERDATA | Sets the 32-bit value associated with the window. Each window has a corresponding 32-bit value intended for use by the application that created the window. This value is initially zero. | hWnd Call SetWindowLong ;M :M GetStyle: ( -- style ) \ *G Retrieves the window styles. GWL_STYLE GetWindowLong: self ;M :M SetStyle: ( style -- ) \ *G Sets a new window style. GWL_STYLE SetWindowLong: self drop ;M :M +Style: ( style -- ) \ *G Add a window style. GetStyle: self OR SetStyle: self ;M :M -Style: ( style -- ) \ *G Remove a window style. INVERT GetStyle: self AND SetStyle: self ;M :M SetFocus: ( -- ) \ *G The SetFocus function sets the keyboard focus to the window. The window must be \ ** attached to the calling thread's message queue. hWnd Call SetFocus drop ;M :M SetForegroundWindow: ( -- ) \ *G The SetForegroundWindow function puts the thread that created the specified window \ ** into the foreground and activates the window. Keyboard input is directed to the window, \ ** and various visual cues are changed for the user. The system assigns a slightly higher \ ** priority to the thread that created the foreground window than it does to other threads. \n \ ** The foreground window is the window at the top of the Z order. It is the window that the \ ** user is working with. In a preemptive multitasking environment, you should generally let the \ ** user control which window is the foreground window. \n \ ** Windows 98, Windows 2000: The system restricts which processes can set the foreground window. \ ** A process can set the foreground window only if one of the following conditions is true: \n \ ** - The process is the foreground process. \n \ ** - The process was started by the foreground process. \n \ ** - The process received the last input event. \n \ ** - There is no foreground process. \n \ ** - The foreground process is being debugged. \n \ ** - The foreground is not locked (see LockSetForegroundWindow). \n \ ** - The foreground lock time-out has expired (see SPI_GETFOREGROUNDLOCKTIMEOUT in SystemParametersInfo). \n \ ** - Windows 2000: No menus are active. \n \ ** With this change, an application cannot force a window to the foreground while the user is \ ** working with another window. Instead, SetForegroundWindow will activate the window (see SetActiveWindow) \ ** and call the FlashWindowEx function to notify the user. For more information, see Foreground and \ ** Background Windows. \n \ ** A process that can set the foreground window can enable another process to set the foreground window by \ ** calling the AllowSetForegroundWindow function. The process specified by dwProcessId loses the ability to \ ** set the foreground window the next time the user generates input, unless the input is directed at that \ ** process, or the next time a process calls AllowSetForegroundWindow, unless that process is specified. \n \ ** The foreground process can disable calls to SetForegroundWindow by calling the LockSetForegroundWindow function. hWnd (SetForegroundWindow) ;M :M SetActiveWindow: ( -- ) \ *G The SetActiveWindow function activates a window. The window must be attached to the calling thread's message queue. \n \ ** The SetActiveWindow function activates a window, but not if the application is in the background. The window will be \ ** brought into the foreground (top of Z order) if its application is in the foreground when the system activates the window. \n \ ** If the window identified by the hWnd parameter was created by the calling thread, the active window status of the calling \ ** thread is set to hWnd. Otherwise, the active window status of the calling thread is set to NULL. \n \ ** By using the AttachThreadInput function, a thread can attach its input processing to another thread. \ ** This allows a thread to call SetActiveWindow to activate a window attached to another thread's message queue. hWnd (SetActiveWindow) ;M :M MessageBox: ( szText szTitle style -- result ) \ *G The MessageBox function creates, displays, and operates a message box. The message box contains an \ ** application-defined message and title, plus any combination of predefined icons and push buttons. \ *L \ *| szText | Pointer to a null-terminated string that contains the message to be displayed. | \ *| szTitle | Pointer to a null-terminated string that contains the dialog box title. If this parameter is NULL, the default title Error is used. | \ *| Type | Specifies the contents and behavior of the dialog box. This parameter can be a combination of flags from the following groups of flags. | \ *P To indicate the buttons displayed in the message box, specify one of the following values. | \ *L \ *| MB_ABORTRETRYIGNORE | The message box contains three push buttons: Abort, Retry, and Ignore. | \ *| MB_CANCELTRYCONTINUE | Windows 2000: The message box contains three push buttons: Cancel, Try Again, Continue. Use this message box type instead of MB_ABORTRETRYIGNORE. | \ *| MB_HELP | Adds a Help button to the message box. When the user clicks the Help button or presses F1, the system sends a WM_HELP message to the owner. | \ *| MB_OK | The message box contains one push button: OK. This is the default. | \ *| MB_OKCANCEL | The message box contains two push buttons: OK and Cancel. | \ *| MB_RETRYCANCEL | The message box contains two push buttons: Retry and Cancel. | \ *| MB_YESNO | The message box contains two push buttons: Yes and No. | \ *| MB_YESNOCANCEL | The message box contains three push buttons: Yes, No, and Cancel. | \ *P To display an icon in the message box, specify one of the following values. \ *L \ *| MB_ICONEXCLAMATION, MB_ICONWARNING | An exclamation-point icon appears in the message box. | \ *| MB_ICONINFORMATION, MB_ICONASTERISK | An icon consisting of a lowercase letter i in a circle appears in the message box. | \ *| MB_ICONQUESTION | A question-mark icon appears in the message box. | \ *| MB_ICONSTOP, MB_ICONERROR, MB_ICONHAND | A stop-sign icon appears in the message box. | \ *P To indicate the default button, specify one of the following values. \ *L \ *| MB_DEFBUTTON1 | The first button is the default button. MB_DEFBUTTON1 is the default unless MB_DEFBUTTON2, MB_DEFBUTTON3, or MB_DEFBUTTON4 is specified. \ *| MB_DEFBUTTON2 | The second button is the default button. | \ *| MB_DEFBUTTON3 | The third button is the default button. | \ *| MB_DEFBUTTON4 | The fourth button is the default button. | \ *P To specify other options, use one or more of the following values. \ *L \ *| MB_RIGHT | The text is right-justified. | \ *| MB_SETFOREGROUND | The message box becomes the foreground window. Internally, the system calls the SetForegroundWindow function for the message box. | \ *| MB_TOPMOST | The message box is created with the WS_EX_TOPMOST window style. | \ *P If the function succeeds, the return value is one of the following menu-item values. \ *L \ *| IDABORT | Abort button was selected. | \ *| IDCANCEL | Cancel button was selected. | \ *| IDCONTINUE | Continue button was selected. | \ *| IDIGNORE | Ignore button was selected. | \ *| IDNO No | button was selected. | \ *| IDOK OK | button was selected. | \ *| IDRETRY | Retry button was selected. | \ *| IDTRYAGAIN | Try Again button was selected. | \ *| IDYES | Yes button was selected. | 3reverse hWnd Call MessageBox ;M :M InvalidateRect: ( bgflag rectangle -- ) \ *G The InvalidateRect function adds a rectangle to the window's update region. \ ** The update region represents the portion of the window's client area that must be redrawn. \ *L \ *| lpRect | Pointer to a RECT structure that contains the client coordinates of the rectangle to be added to the update region. If this parameter is NULL, the entire client area is added to the update region. | \ *| bErase | Specifies whether the background within the update region is to be erased when the update region is processed. If this parameter is TRUE, the background is erased when the BeginPaint function is called. | hWnd call InvalidateRect ?win-error ;M :M GetDlgItem: ( id -- handle ) \ *G The GetDlgItem function retrieves a handle of the control (id) in the window. hWnd Call GetDlgItem ;M :M GetDlgItemText: ( addr len id -- len ) \ *G The GetDlgItemText function retrieves the title or text associated with a control in the window. >r swap r> hWnd Call GetDlgItemText ;M :M SetDlgItemText: ( addr len id -- ) \ *G The SetDlgItemText function sets the title or text of a control in then window. >r asciiz r> hWnd Call SetDlgItemText drop ;M :M SetDlgItemFocus: ( id -- ) \ *G Set the focus to the control (id) in the window. GetDlgItem: self Call SetFocus drop ;M :M SelectDlgItemAll: ( id -- ) \ *G Selects all characters in the edit control (id). You can use this forn an edit control \ ** or a rich edit control. >r -1 0 EM_SETSEL r> hWnd Call SendDlgItemMessage drop ;M :M IsDlgButtonChecked: ( id -- f1 ) \ *G The IsDlgButtonChecked function determines whether a button control has a check mark next to \ ** it or whether a three-state button control is grayed, checked, or neither. hWnd Call IsDlgButtonChecked ;M :M CheckDlgButton: ( uCheck id -- ) \ *G The CheckDlgButton function changes the check state of a button control. \ ** Possible values for uCheck are: \ *L \ *| BST_CHECKED | Sets the button state to checked. | \ *| BST_INDETERMINATE | Sets the button state to grayed, indicating an indeterminate state. Use this value only if the button has the BS_3STATE or BS_AUTO3STATE style. | \ *| BST_UNCHECKED | Sets the button state to cleared | hWnd Call CheckDlgButton drop ;M :M SetDlgItemAlign: ( flag id -- ) \ *G Set the text-alignment for a control (id) in the window. \n \ ** The current position is updated after each text output call. \ ** The current position is used as the reference point. \ ** Possible values for flag are: \ *L \ *| 0 | The reference point will be on the left edge of the bounding rectangle. | \ *| 1 | The reference point will be on the right edge of the bounding rectangle. | \ *| 2 | The reference point will be aligned horizontally with the center of the bounding rectangle. | GetDlgItem: self (SetTextAlign) ;M :M SetAlign: ( flag id -- ) \ DEPRECATED \ *G Obsolescent Method use SetDlgItemAlign: instead. SetDlgItemAlign: self ;M DEPRECATED :M EnableDlgItem: ( flag id -- ) \ *G Enable or disable a control (id) in the window. \ ** Possible values for flag are: \ *L \ *| 0 | disable | \ *| 1 | enable | GetDlgItem: self Call EnableWindow drop ;M :M ShowDlgItem: ( flag id -- ) \ *G Hide or show a control (id) in the window. \ ** Possible values for flag are: \ *L \ *| 0 | hide | \ *| 1 | show | swap if SW_SHOWNORMAL else SW_HIDE then swap GetDlgItem: self Call ShowWindow drop ;M :M CheckRadioButton: ( check_id first_id last_id -- ) \ *G The CheckRadioButton function adds a check mark to (checks) a specified radio button \ ** in a group and removes a check mark from (clears) all other radio buttons in the group. \ *L \ *| check_id | Specifies the identifier of the radio button to select. | \ *| first_id | Specifies the identifier of the first radio button in the group. | \ *| last_id | Specifies the identifier of the last radio button in the group. | swap hWnd Call CheckRadioButton drop ;M :M SendDlgItemMessage: ( lParam wParam message id -- long ) \ *G Send a message to the control (id) in the window. hWnd Call SendDlgItemMessage ;M :M SetDlgItemFont: ( FontObject id -- ) \ *G Specify the font that the control (id) is to use when drawing text. \n \ ** FontObject must be the HANDLE of a font. If this parameter is NULL, the control uses the \ ** default system font to draw text. 1 -rot WM_SETFONT swap SendDlgItemMessage: self ;M (( \ The following definitions are for handling Dialog messages and have been moved \ here rather than have multiple copies of the code in different descendants : +DialogList ( -- ) \ link into dialog list (dialoglock) Dialog-link link, self , Dialog-link @ (dialogunlock) to mydialoglink ; : -DialogList ( -- ) \ Unlink from dialog list (dialoglock) mydialoglink Dialog-link un-link drop (dialogunlock) ; )) : DoDialogMsg { pMsg flag -- pMsg f | pMsg FALSE } (dialoglock) Dialog-link \ all dialog handles begin @ dup 0<> \ while not end of chain flag and \ and haven't found a handler while dup>r cell+ @ Gethandle: generic-window -if pMsg swap Call IsDialogMessage then 0= to flag r> repeat (dialogunlock) drop pMsg flag ; msg-chain chain-add DoDialogMsg ;CLASS \ *G End of generic-window class : zero-windows ( -- ) \ Zero all window handles. windows-link begin @ ?dup while dup cell+ @ ZeroWindow: [ ] repeat ; initialization-chain chain-add zero-windows in-system \ *W <a name="DIALOG&CONTROL"></a> \ *S Generic class for Dialog- and Control-Window objects. |CLASS DIALOG&CONTROL <SUPER Generic-Window \ *G Base class for all dialog and control objects. \ *P Since DIALOG&CONTROL is a generic class it should not be used to create \ ** any instances. in-application int mydialoglink \ The following is for backward compatibility. Use WinRect for new code since it will \ be early bound whereas wRect will be latebound. int wRect Rectangle WinRect synonym tempRect wRect :M Classinit: ( -- ) \ *G Initialise the class. ClassInit: super 0 to mydialoglink \ added Sonntag, Juni 04 2006 dbu addr: WinRect to wRect ;M :M GetWindowRect: ( -- left top right bottom ) \ *G The GetWindowRect method retrieves the dimensions of the bounding rectangle of the window. \ ** The dimensions are given in screen coordinates that are relative to the upper-left corner \ ** of the screen. hWnd if EraseRect: WinRect AddrOf: WinRect hWnd Call GetWindowRect ?win-error Left: WinRect Top: WinRect Right: WinRect Bottom: WinRect else 0 0 0 0 then ;M \ Temporarily moved here to overcome problem with offset of ints in Window.f : +DialogList ( -- ) \ link into dialog list (dialoglock) Dialog-link link, self , Dialog-link @ (dialogunlock) to mydialoglink ; : -DialogList ( -- ) \ Unlink from dialog list (dialoglock) mydialoglink Dialog-link un-link drop (dialogunlock) ; ;CLASS \ *G End of DIALOG&CONTROL class \ *Z --- NEW FILE: Utils.f --- \ $Id: Utils.f,v 1.1 2007/04/30 07:49:26 georgeahubert Exp $ \ UTILS.F A file to hold some utilities by Tom Zimmer \ -rbs globalized path init \ Changes February 14th, 2002 - 1:37 - rls \ utils.f beta 2.0A 2002/08/31 arm windows ANS file words \ utils.f beta 2.9G 2002/09/24 arm release for testing \ utils.f beta 3.3D 2002/10/08 arm Consolidated cr .( Loading Utility Words...) only forth also definitions needs GdiTools.f needs Class.f in-application : screen-size ( -- width height ) \ get windows screen size SM_CXSCREEN call GetSystemMetrics \ screen width SM_CYSCREEN call GetSystemMetrics ; \ screen height \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 5 Display the deferred words in the system, and their *current function \ along with the default function. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IN-SYSTEM \ : .deferred ( -- ) \ defer-list @ \ begin ?dup \ while cr ." Deferred: " \ dup cell - dup body> .NAME \ 23 col ." does: " @ .NAME \ 45 col ." defaults to: " dup cell+ @ .NAME \ @ \ start/stop \ repeat ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 5a Display the current file \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ : .cur-file ( -- ) \ ." The current file is: " cur-file count type ; \ \ synonym .file .cur-file \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : .platform ( -- ) cr ." Platform: Windows " winver case WIN95 of ." 95" endof WIN98 of ." 98" endof WINME of ." ME" endof WINNT351 of ." NT3.51" endof WINNT4 of ." NT4" endof WIN2K of ." 2000" endof WINXP of ." XP" endof WIN2003 of ." 2003" endof endcase ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 7 Display the files loaded into the system \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ also hidden \ \ : .loaded ( -- ) \ also files \ screendelay 0 to screendelay \ false to with-tabs? \ _words \ previous to screendelay ; \ previous \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ display a Message Box \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IN-APPLICATION : MessageBox ( szText szTitle style hOwnerWindow -- result ) dup NULL = if drop call GetActiveWindow then \ better use a valid handle >r 3reverse r> Call MessageBox ; : ?MessageBox ( flag adr len -- ) asciiz swap if z" Notice!" [ MB_OK MB_ICONINFORMATION or MB_TASKMODAL or ] literal NULL MessageBox then drop ; \ : ?ErrorBox ( flag adr len -- ) asciiz swap if z" Application Error" [ MB_OKCANCEL MB_ICONWARNING or MB_TASKMODAL or ] literal NULL MessageBox IDCANCEL = if bye then abort else drop then ; \ : ?TerminateBox ( flag adr len -- ) asciiz swap if z" Error Notice!" [ MB_OK MB_ICONSTOP or MB_TASKMODAL or ] literal NULL MessageBox drop bye else drop then ; \ : ErrorBox ( adr len -- ) asciiz z" Application Error" [ MB_TASKMODAL MB_ICONERROR or ] literal NULL MessageBox drop ; \ : .ErrorBox ( n - ) \ displays n in a MessageBox 0 (d.) ErrorBox ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ primitive utilities to support VIEW, BROWSE, EDIT and LOCATE \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ variable cur-line cur-line off INTERNAL \ internal definitions start here IN-SYSTEM (( : editor-wait { \ ?deadlook -- } \ wait until the editor is ready to accept messages 0 to ?deadlook \ return's after 10 seconds even when the editor is not ready begin 100 ms WINPAUSE ?deadlook 1+ dup to ?deadlook 100 = editor-present? or until ; : editor-run ( addr -- ) $exec 0= if editor-wait \ wait for the editor to be ready 0 ED_ALIVE editor-message \ tell the Editor that we are ready to compile then ; : do-edit ( -- ) editor-present? \ TRUE if editor is loaded if cur-file count "path-file drop ed-filename place cur-line @ ed-line ! 0 ED_OPEN_EDIT editor-message else editor$ editor-run \ startup the editor then ; : do-browse ( -- ) editor-present? \ TRUE if editor is loaded if cur-file count "path-file drop ed-filename place cur-line @ ed-line ! ed-column off 0 ED_OPEN_BROWSE editor-message else browse$ editor-run \ startup the editor then ; )) [defined] watched-cfa [if] : do-watch { \ pocket$ -- } MAXSTRING LocalAlloc: pocket$ \ a place to preserve pocket pocket pocket$ MAXSTRING move \ get current pocket contents editor-present? \ TRUE if editor is loaded if cur-file count "path-file if 2drop cur-file count then ed-filename place watched-cfa >name nfa-count ed-name place cur-line @ ed-line ! ed-column off 0 ED_WATCH editor-message else ed-ptr if watched-cfa >name nfa-count ed-name place then browse$ editor-run \ startup the editor then pocket$ pocket MAXSTRING move ; \ restore contents of pocket [else] : do-watch ; [then] IN-APPLICATION (( \ changed to work with blanks in filename \ September 9th, 2003 - 15:05 dbu : [$edit] { line_number file_name edit_cfa -- } file_name -1 <> if \ don't know for what this is good, but it keep us working with \ blanks in filenames. September 9th, 2003 - 15:05 dbu \ file_name count bl skip 2dup bl scan 2dup 2>r nip - \ "CLIP" cur-file place \ 2r> bl skip dup \ if number? 2drop 1 max to line_number \ else 2drop \ then file_name count bl skip "CLIP" cur-file place line_number &linenum ! \ set the line# variables line_number cur-line ! edit_cfa execute \ execute the editor then ; EXTERNAL \ external definitions start here : $edit ( line filename | dummy -1 -- ) ['] do-edit [$edit] ; : $browse ( line filename | dummy -1 -- ) ['] do-browse [$edit] ; INTERNAL )) in-system [defined] $watch [if] : _$watch ( line filename -- ) ['] do-watch [$edit] ; ' _$watch is $watch \ link watch into the debugger [then] : locate-height ( -- n1 ) getcolrow nip 8 - 20 min ; : locate-header ( -- n1 ) locate-height 4 / ; -1 value orig-loc (( : $locate ( line# filename | dummy -1 -- ) { line# file$ \ loc$ locHdl lcnt -- } file$ ( 0< ) -1 = ?EXIT \ September 9th, 2003 - 15:18 dbu max-path LocalAlloc: loc$ file$ $open abort" Couldn't open source file!" to locHdl 0 to lcnt base @ >r decimal cls ." From file: " cur-file count type ." At line: " line# . line# cur-line ! cr horizontal-line line# locate-header - 0 max 0 ?do loc$ MAXCOUNTED locHdl read-line abort" Read Error" nip 0= ?leave 1 +to lcnt loop locate-height 0 do loc$ dup MAXCOUNTED locHdl read-line abort" Read Error" if cols 1- min 1 +to lcnt lcnt orig-loc = if horizontal-line type cr horizontal-line else type cr then getxy nip getcolrow nip 4 - > ?leave else 2drop leave then loop horizontal-line locHdl close-file drop r> base ! ; )) in-application EXTERNAL \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 9 Handle error returned by window functions \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ defer win-abort ' abort is win-abort : ?win-error ( f1 -- ) \ f1=0=failed \ ?win-error can only be used right after a CALL. It looks at the CALL word, \ finds the PROC and extracts the name of the function. It's a pretty nasty \ bit of code! The bit that does it is: \ \ r@ 2 cells - @ .proc-name \ \ Fetches the current IP, then goes 2 cells back (the pointer is always a \ cell ahead at the next word, so 1 cell back is the ?win-error word, 2 \ cells is the CALL). This is the pointer to the CALL CFA in the PROC; then \ it fetches the PROC address and displays the name. Horrible. 0= ?win-error-enabled and if \ build string for error message debugging WinErrMsg @ WinErrMsg OFF GetLastWinErr SWAP WinErrMsg ! DUP NO_ERROR <> if false to ?win-error-enabled \+ debug-io debug-io cr ." On Function: " \ r@ 2 cells - @ \ \+ .proc-name .proc-name \ Horrible... ( \- .proc-name h. ) ." Unspecified " ." Windows Returned Error: " . temp$ count type tabbing-off forth-io win-abort \+ restore-io restore-io else drop then then ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : copyfile { \ from$ to$ -<from to>- } \ copy a file to a directory max-path localAlloc: from$ max-path localAlloc: to$ /parse-s$ count from$ place /parse-s$ count to$ place to$ ?+\ from$ count "to-pathend" to$ +place from$ +NULL to$ +NULL cr ." Copying: " from$ count type cr ." To: " to$ count type false to$ 1+ from$ 1+ Call CopyFile 0= abort" The COPY Failed!" ; in-system \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 11 More primitive utilities to support view, browse and edit \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ (( : $.viewinfo ( cfa -- line filename ) get-viewfile 0= abort" Undefined word!" ." loaded from: " over 0< if 2drop consfile count type 0 -1 else base @ >r decimal dup ?uppercase count type 15 ?cr ." at line: " swap dup . swap r> base ! dup count cur-file place then ; : .viewinfo ( -<name>- line filename ) bl word anyfind if $.viewinfo else c@ abort" Undefined word!" cur-line @ cur-file then over to orig-loc ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 12 Highlevel words used to view, browse and edit words and file \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : where ( -<name>- ) \ tell me WHERE the source for a word is .viewinfo drop cur-line ! ; synonym .v where : locate ( -<name>- ) \ show some source lines of word .viewinfo $locate ; synonym l locate synonym ll locate : n ( -- ) \ show the next bunch of lines cur-line @ locate-height 4 - + cur-file $locate ; \ removed B because it's a valid HEX number \ September 23rd, 2003 - 10:44 dbu \ : b ( -- ) \ show the previous bunch of lines \ cur-line @ locate-height 4 - - 0 max cur-file $locate ; : linelist ( n1 -- ) cur-file $locate ; : view ( -<name>- ) \ VIEW the source for a word .viewinfo $browse ; synonym v view \ V is an synonym for VIEW synonym Vv view \ Vv is an synonym for VIEW jap : ed ( -<name>- ) \ EDIT the source for a word .viewinfo $edit ; \ removed E because it's a valid HEX number \ September 23rd, 2003 - 10:44 dbu \ synonym e ed \ E is a synonym for EDIT : edit ( -<filename>- ) \ EDIT a particular file 0 word c@ if cur-line off 0 pocket else cur-line @ cur-file then $edit ; synonym z edit \ Z is a synonym for EDIT : browse ( -<filename>- ) \ BROWSE a particular file 0 word c@ if cur-line off 0 pocket else cur-line @ cur-file then $browse ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 13 Compiler utilities \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 14 Utility to allow loading a file starting at a specified line number \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ VARIABLE START-LINE \ Allows you to start including a file at a line number \ other than 1. Can't think of a serious use for it. \ Not ANS. Dangerious, We are advised - don't use it. : >LINE ( n1 -- ) \ move to line n1, 1 based 1- 0 MAX ?DUP IF 0 DO REFILL DROP LOOP THEN ; : #fload ( n1 -<name>- ) \ load file "name" from line n1, 1 based start-line ! \ set start line /parse-s$ $fload ; \ do the load : lineload ( n1 -- ) \ load the current file from line n1 start-line ! cur-file $fload ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 15 Linkage to automatically invoke the editor on a compile error \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : _edit-error ( -- ) loadline @ loadfile $edit ; : autoediton ( -- ) \ link into deferred auto edit on error word ['] _edit-error is edit-error ; autoediton : autoeditoff ( -- ) \ disable automatic edit on error ['] noop is edit-error ; in-application \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 16 A simple error number extension to error handling \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ : ?error ( f1 n1 -- ) \ abort with error code n1 if f1=true \ now as ?THROW in kernel; ?error is unused \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 17 ANSI Save and Restore Input Functions \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ In kernel \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Compile time stack depth checking (Part 2 for Part 1 see Primeutil.f) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IN-SYSTEM \ add stack message increased THROW_MSGS LINK, -4103 ( WARN_STACK ) , ," stack depth increased" : _stack-check ( -- ) loading? 0= \ if we are not loading state @ or \ or we are in compile state, \ then don't check stack depth change olddepth 0< or ?exit \ or if olddepth is below zero \ or if assembling context @ [ ' assembler vcfa>voc ] literal = ?exit depth olddepth > \ if stack depth has increased if \ then warn of extra item on stack -4103 ( WARN_STACK ) WARNMSG cr ." Stack: " .s cr then depth to olddepth ; \ If interpretation of files is done in a TURNKEYed application this must be \ reset to NOOP \in-system-ok ' _stack-check is stack-check )) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 19 Time control words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IN-APPLICATION 16 constant TIME-LEN next-user dup @ aligned swap ! time-len newuser TIME-BUF \ +0 year \ +2 month \ +4 day of week \ +6 day of month \ +8 hour \ +10 minute \ +12 second \ +14 milliseconds 32 newuser date$ 32 newuser time$ : get-local-time ( -- ) \ get the local computer date and time time-buf call GetLocalTime drop ; create compile-version time-len allot \ a place to save the compile time (global) get-local-time \ save as part of compiled image time-buf compile-version time-len move \ move time into buffer : time&date ( -- sec min hour day month year ) get-local-time time-buf 12 + w@ \ seconds time-buf 10 + w@ \ minutes time-buf 8 + w@ \ hours time-buf 6 + w@ \ day of month time-buf 2 + w@ \ month of year time-buf w@ ; \ year : .#" ( n1 n2 -- a1 n3 ) >r 0 <# r> 0 ?do # loop #> ; : >date" ( time_structure -- ) >r 31 date$ null \ z" ddddd',' MMMM dd yyyy" r> null LOCALE_USER_DEFAULT call GetDateFormat date$ swap 1- ; : .date ( -- ) \ *G Print date in short format, based on regional setting. get-local-time time-buf >date" type ; : >month,day,year" ( time_structure -- ) >r 31 date$ z" ddddd',' MMMM dd yyyy" r> null LOCALE_USER_DEFAULT call GetDateFormat date$ swap 1- ; : .month,day,year ( -- ) \ *G Print day and date in full. get-local-time time-buf >month,day,year" type ; : >time" ( time_structure -- ) >r 31 time$ null r> null LOCALE_USER_DEFAULT call GetTimeFormat time$ swap 1- ; : .time ( -- ) \ *G Print time in 24hr format. get-local-time time-buf >time" type ; : >am/pm" ( time_structure -- ) >r 31 time$ z" h':'mmtt" r> null LOCALE_USER_DEFAULT call GetTimeFormat time$ swap 1- ; : .am/pm ( -- ) \ *G Print time in 12hr format. get-local-time time-buf >am/pm" type ; : .cversion ( -- ) cr ." Compiled: " compile-version dup >month,day,year" type ." , " >am/pm" type ; : ms@ ( -- ms ) get-local-time time-buf dup 8 + w@ 60 * \ hours over 10 + w@ + 60 * \ minutes over 12 + w@ + 1000 * \ seconds swap 14 + w@ + ; \ milli-seconds 0 value start-time : time-reset ( -- ) ms@ to start-time ; ' time-reset alias timer-reset : .elapsed ( -- ) ." Elapsed time: " ms@ start-time - 1000 /mod 60 /mod 60 /mod 2 .#" type ." :" 2 .#" type ." :" 2 .#" type ." ." 3 .#" type ; : elapse ( -<commandline>- ) time-reset interpret cr .elapsed ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ module \s internal fload builtby.f external : .Builtby ( -- ) \ print the name of the person who built this copy of w32f builtby count ?dup if cr ." Built by: " type else drop then ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 20 Random number generator for Win32Forth \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 3141592 value SEED1 6535897 value SEED2 9323846 value SEED3 : RANDOM ( n1 -- n2 ) \ W32F Utils \ *G Get a pseudo random number between 0 and n1 as n2. n2 has the same sign as n1. dup 0= if 1+ then SEED1 177 /MOD 2* SWAP 171 * SWAP - DUP to SEED1 SEED2 176 /MOD 35 * SWAP 172 * SWAP - DUP to SEED2 SEED3 178 /MOD 63 * SWAP 170 * SWAP - DUP to SEED3 + + SWAP MOD ; : RANDOM-INIT ( -- ) \ W32F Utils \ *G Initialize the random number generator from the system clock. This is performed at \ ** program initialisation. get-local-time time-buf 3 cells + @ to SEED1 time-buf 2 cells + @ to SEED2 time-buf 1 cells + @ to SEED3 ; INITIALIZATION-CHAIN CHAIN-ADD RANDOM-INIT \ randomize at boot time \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 21 Delay Time Words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ old Win32s support removed \ September 17th, 2003 - 10:38 dbu : _MS ( u -- ) \ delay u milli-seconds or forever if u=-1. Call Sleep drop ; ' _MS IS MS : SECONDS ( n1 -- ) 0max 0 ?do 10 0 do 100 ms key? if key drop unloop unloop EXIT then loop loop ; IN-SYSTEM : pause-seconds ( n1 -- ) cr ." Delaying: " dup . ." seconds, press a key to HOLD " 30 min 1 max 10 * 0 ?do 100 ms key? if cr ." HOLDING, Space=continue delaying, Enter=cancel pause, ESC=abort" key dup k_ESC = if cr ." Aborted" abort then K_CR = ?leave key dup k_ESC = if cr ." Aborted" abort then K_CR = ?leave cr ." Press a key to pause " then loop ; synonym ?keypause start/stop \ from F-PC, pauses if a key is pressed \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 22 File type \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : "ftype { \ locHdl typ$ -<name>- } \ type file "name" to the console max-path LocalAlloc: typ$ "open abort" Couldn't open file!" to locHdl cur-line off cr ." Typing file: " open-path$ count type cr begin typ$ dup MAXCOUNTED locHdl read-line abort" Read Error" nuf? 0= and while type cr 10 ms repeat locHdl close-file 3drop ; : ftype ( -<filename>- ) \ W32F System Utils \ *G Type the contents of file -<filename>- at the console. If no extension is supplied \ ** then the default extension (.f) is applied. Relative paths are relative to the Forth \ ** search path. /parse-s$ count "ftype ; synonym flist ftype \ *G Alternate name. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 23 An addition to CASE OF ENDOF ENDCASE, to allow testing ranges \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : _of-range ( n1 n2 n3 -- n1 f1 ) 2 pick -rot between ; : of-range ( n1 n2 n3 -- n1 ) \ extension to CASE for a range ?comp POSTPONE _of-range POSTPONE ?branch >mark 4 ; immediate in-application \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ EXTERNAL : make-cursor ( cursor_constant appinst -- ) create , , does> dup cell+ @ swap @ if z" w32fConsole.dll" Call GetModuleHandle else NULL then Call LoadCursor Call SetCursor drop ; \ Standard Win32 API Cursors IDC_APPSTARTING FALSE make-cursor appstarting-cursor IDC_ARROW FALSE make-cursor arrow-cursor IDC_CROSS FALSE make-cursor cross-cursor IDC_HELP FALSE make-cursor help-cursor IDC_IBEAM FALSE make-cursor ibeam-cursor IDC_NO FALSE make... [truncated message content] |
Update of /cvsroot/win32forth/win32forth-stc/src/gdi In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv32749/win32forth-stc/src/gdi Modified Files: gdiStruct.f Added Files: gdi.f gdiBitmap.f gdiBrush.f gdiDC.f gdiFont.f gdiMetafile.f gdiMetafileDc.f gdiWindowDc.f Log Message: gah:Added the rest of the gdi functions and some other class files updated primutil.f with extra utilities needed for GUI and bugfixes/extensions to class.f --- NEW FILE: gdiMetafile.f --- \ *D doc\classes\ \ *! gdiMetafile \ *T gdiMetafile -- Metafile class \ *Q Version 1.0 \ ** This GDI class library was written and placed in the Public Domain \ ** in 2005 by Dirk Busch \ *S Glossary cr .( Loading GDI class library - Metafile...) needs gdiBase.f needs gdiDC.f internal external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ *W <a name="gdiMetafile"></a> :class gdiMetafile <super gdiObject \ *G Metafile class. This class only support's enhanced metafiles (emf) ! rectangle RECT :M ClassInit: ( -- ) ClassInit: super ;M :M Destroy: ( -- ) \ *G Destroy the metafile. hObject ?dup if call DeleteEnhMetaFile ?win-error 0 to hObject then ;M :M SetHandle: ( hMF -- ) \ *G Set the handle of the metafile. Destroy: self to hObject ;M :M Copy: ( -- hCopy ) \ *G Create a copy of the metafile in memory hObject if 0 hObject call CopyEnhMetaFile else null then ;M : FileName ( addr len -- addr1 ) pad place pad +null pad 1+ ; :M Load: ( addr len -- f ) \ *G Load a metafile from a file FileName call GetEnhMetaFile SetHandle: self Valid?: super ;M :M Save: ( addr len -- f ) \ *G Save the metafile in a file hObject if FileName hObject call CopyEnhMetaFile dup if call DeleteEnhMetaFile ?win-error true else false then else 2drop false then ;M :M PlayInRect: ( left top right bottom hDestDC -- ) \ *G Play the metafile in a rectangle GetGdiObjectHandle >r SetRect: RECT AddrOf: RECT hObject r> call PlayEnhMetaFile drop ;M :M CopyToClipboard: ( -- ) \ *G Copy the metafile to the clipboard 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 :M GetFromClipboard: ( -- ) \ *G Get a metafile from the clipboard null call OpenClipboard ?win-error CF_ENHMETAFILE call GetClipboardData call CloseClipboard ?win-error ?dup if null swap call CopyEnhMetaFile SetHandle: self then ;M :M GetFileHeader: ( pemh size -- n ) \ *G The GetFileHeader: method retrieves the record containing the header \ ** for the specified enhanced-format metafile. \n \ ** 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. \n \ ** size Specifies the size, in bytes, of the buffer to receive the data. Only this \ ** many bytes will be copied. hObject call GetEnhMetaFileHeader ;M :M GetPaletteEntries: ( cEntries lppe -- n ) \ *G The GetPaletteEntries: methods retrieves optional palette entries from the \ ** specified enhanced metafile. \n \ ** cEntries Specifies the number of entries to be retrieved from the optional \ ** palette. \n \ ** 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. swap hObject call GetEnhMetaFilePaletteEntries ;M ;class \ *G End of gdiMetafile class module \ *Z --- 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 --- \ *D doc\classes\ \ *! gdiBitmap \ *T gdiBitmap -- GDI Bitmap class. \ *Q Version 1.0 \ ** This GDI class library was written and placed in the Public Domain \ ** in 2005 by Dirk Busch \ *S Glossary cr .( Loading GDI class library - Bitmap...) needs gdiBase.f internal external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Bitmap class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ *W <a name="gdiBitmap"></a> :class gdiBitmap <super gdiObject \ *G Bitmap class gdiSize SIZE :M ClassInit: ( -- ) ClassInit: super ;M :M CreateBitmap: ( Width Height Planes BitsPerPel pBits -- f ) \ *G The CreateBitmap function creates a bitmap with the specified width, height, \ ** and color format (color planes and bits-per-pixel). \n \ ** \n \ ** Width Specifies the bitmap width, in pixels. \n \ ** Height Specifies the bitmap height, in pixels. \n \ ** Planes Specifies the number of color planes used by the device. \n \ ** BitsPerPel Specifies the number of bits required to identify the color of a \ ** single pixel. \n \ ** 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. \n \ ** \n \ ** 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. \n \ ** \n \ ** If the bitmap is monochrome, zeros represent the foreground color and ones represent \ ** the background color for the destination device context. \n \ ** \n \ ** If an application sets the nWidth or nHeight parameters to zero, CreateBitmap \ ** returns the handle to a 1-by-1 pixel, monochrome bitmap. \n \ ** \n \ ** When you no longer need the bitmap, call the Destroy: method to delete it. \n \ ** \n \ ** Windows 95/98: The created bitmap cannot exceed 16MB in size 5reverse call CreateBitmap SetHandle: super Valid?: super ;M :M CreateBitmapIndirect: ( pBitmap -- f ) \ *G 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. call CreateBitmapIndirect SetHandle: super Valid?: super ;M :M CreateCompatibleBitmap: ( Width Height hDC -- f ) \ *G The CreateCompatibleBitmap function creates a bitmap compatible with the device \ ** that is associated with the specified device context. \n \ ** \n \ ** 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. \n \ ** \n \ ** 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. \n \ ** \n \ ** 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: \n \ ** \n \ ** HDC memDC = CreateCompatibleDC ( hDC ); \n \ ** HBITMAP memBM = CreateCompatibleBitmap ( hDC ); \n \ ** SelectObject ( memDC, memBM ); \n \ ** \n \ ** If an application sets the nWidth or nHeight parameters to zero, CreateCompatibleBitmap \ ** returns the handle to a 1-by-1 pixel, monochrome bitmap. \n \ ** \n \ ** 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. \n \ ** \n \ ** When you no longer need the bitmap, call the DeleteObject function to delete it. \n \ ** \n \ ** Windows 95/98: The created bitmap cannot exceed 16MB in size. GetGdiObjectHandle >r swap r> call CreateCompatibleBitmap SetHandle: super Valid?: super ;M :M CreateDIBitmap: ( pbmih fdwInit pbInit pbmi fuUsage hdc -- f ) \ *G The CreateDIBitmap function creates a device-dependent bitmap (DDB) from a DIB and, \ ** optionally, sets the bitmap bits. \n \ ** lpbmih Pointer to a bitmap information header structure, which may be one of those \ ** shown in the following table. \ *L \ *| 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 !!!) | \ *P 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. \n \ ** 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. \n \ ** If fdwInit is zero, the system does not initialize the bitmap's bits. \n \ ** 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. \n \ ** lpbmi Pointer to a BITMAPINFO structure that describes the dimensions and color format of the \ ** array pointed to by the lpbInit parameter. \n \ ** 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. \ *L \ *| 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. | GetGdiObjectHandle >r 5reverse r> call CreateDIBitmap SetHandle: super Valid?: super ;M :M CreateDIBSection: ( pbmi iUsage ppvBits hSection dwOffset hdc -- f ) \ *G 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. \n \ ** 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. \n \ ** pbmi Pointer to a BITMAPINFO structure that specifies various attributes of the DIB, including \ ** the bitmap's dimensions and colors. \n \ ** 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. \ *L \ *| 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. | \ *P ppvBits Pointer to a variable that receives a pointer to the location of the DIB's bit values. \n \ ** 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. \n \ ** 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. GetGdiObjectHandle >r 5reverse r> call CreateDIBSection SetHandle: super Valid?: super ;M :M SetBitmapDimension: ( width height -- oldwidth oldheight ) \ *G The SetBitmapDimension function assigns preferred dimensions to a bitmap. These dimensions can be \ ** used by applications; however, they are not used by the system. \n \ ** Width Specifies the width, in 0.1-millimeter units, of the bitmap. \n \ ** Height Specifies the height, in 0.1-millimeter units, of the bitmap. \n \ ** An application can retrieve the dimensions assigned to a bitmap with the SetBitmapDimensionEx function \ ** by calling the GetBitmapDimension function. \n \ ** 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. Addr: SIZE 3reverse hObject call SetBitmapDimensionEx ?win-error GetX: SIZE GetY: SIZE ;M :M GetBitmapDimension: ( -- width height ) \ *G 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. Addr: SIZE hObject call GetBitmapDimensionEx ?win-error GetX: SIZE GetY: SIZE ;M :M SetDIBits: ;M \ *G not implemented, yet. :M GetDIBits: ;M \ *G not implemented, yet. :M LoadBitmap: ;M \ *G not implemented, yet. :M MaskBlt: ;M \ *G not implemented, yet. :M PlgBlt: ;M \ *G not implemented, yet. ;class \ *G End of Bitmap class module \ *Z --- NEW FILE: gdiFont.f --- \ *D doc\classes\ \ *! gdiFont \ *T gdiFont -- Class for GDI Fonts. \ *Q Version 1.0 \ ** This GDI class library was written and placed in the Public Domain \ ** in 2005 by Dirk Busch \ *S Glossary cr .( Loading GDI class library - Font...) needs gdiBase.f internal external \ ---------------------------------------------------------------------- \ ---------------------------------------------------------------------- \ *W <a name="gdiFont"></a> :Class gdiFont <Super GdiObject \ *G GDI Font class 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 -- ) \ *G Set the height, in logical units, of the font's character cell or character. The character \ ** height value (also known as the em height) is the character cell height value minus the \ ** internal-leading value. The font mapper interprets the value specified in lfHeight in the \ ** following manner. \ *L \ *| > 0 | The font mapper transforms this value into device units and matches it against the cell height of the available fonts. | \ *| 0 | The font mapper uses a default height value when it searches for a match. | \ *| < 0 | The font mapper transforms this value into device units and matches its absolute value against the character height of the available fonts. | \ *P For all height comparisons, the font mapper looks for the largest font that does not exceed \ ** the requested size. This mapping occurs when the font is used for the first time. to lfHeight ;M :M SetWidth: ( n1 -- ) \ *G Specifies the average width, in logical units, of characters in the font. If lfWidth is zero, \ ** the aspect ratio of the device is matched against the digitization aspect ratio of the available \ ** fonts to find the closest match, determined by the absolute value of the difference. to lfWidth ;M :M SetEscapement: ( n1 -- ) \ *G Set the angle, in tenths of degrees, between the escapement vector and the x-axis of the device. \ ** The escapement vector is parallel to the base line of a row of text. \n \ ** Windows NT/ 2000: When the graphics mode is set to GM_ADVANCED, you can specify the escapement \ ** angle of the string independently of the orientation angle of the string's characters. \n \ ** When the graphics mode is set to GM_COMPATIBLE, lfEscapement specifies both the escapement and \ ** orientation. You should set lfEscapement and lfOrientation to the same value. \n \ ** Windows 95: The lfEscapement member specifies both the escapement and orientation. You should set \ ** lfEscapement and lfOrientation to the same value. to lfEscapement ;M :M SetOrientation: ( n1 -- ) \ *G Set the angle, in tenths of degrees, between each character's base line and the x-axis of the device. to lfOrientation ;M \ 10th/degree increments :M SetWeight: ( n1 -- ) \ *G Specifies the weight of the font in the range 0 through 1000. For example, 400 is normal and 700 is bold. \ ** If this value is zero, a default weight is used. The following values are defined for convenience. \ *L \ *| FW_DONTCARE | 0 | \ *| FW_THIN | 100 | \ *| FW_EXTRALIGHT | 200 | \ *| FW_ULTRALIGHT | 200 | \ *| FW_LIGHT | 300 | \ *| FW_NORMAL | 400 | \ *| FW_REGULAR | 400 | \ *| FW_MEDIUM | 500 | \ *| FW_SEMIBOLD | 600 | \ *| FW_DEMIBOLD | 600 | \ *| FW_BOLD | 700 | \ *| FW_EXTRABOLD | 800 | \ *| FW_ULTRABOLD | 800 | \ *| FW_HEAVY | 900 | \ *| FW_BLACK | 900 | to lfWeight ;M :M SetItalic: ( f1 -- ) \ *G Specifies an italic font if set to TRUE. to lfItalic ;M :M SetUnderline: ( f1 -- ) \ *G Specifies an underlined font if set to TRUE. to lfUnderline ;M :M SetStrikeOut: ( f1 -- ) \ *G Specifies a strikeout font if set to TRUE. to lfStrikeOut ;M :M SetCharSet: ( n1 -- ) \ *G Specifies the character set. The following values are predefined. \ *L \ *| ANSI_CHARSET | \ *| BALTIC_CHARSET | \ *| CHINESEBIG5_CHARSET | \ *| DEFAULT_CHARSET | \ *| EASTEUROPE_CHARSET | \ *| GB2312_CHARSET | \ *| GREEK_CHARSET | \ *| HANGUL_CHARSET | \ *| MAC_CHARSET | \ *| OEM_CHARSET | \ *| RUSSIAN_CHARSET | \ *| SHIFTJIS_CHARSET | \ *| SYMBOL_CHARSET | \ *| TURKISH_CHARSET | \ *P Windows NT/ 2000 or Middle-Eastern Windows 3.1 or later: \ *L \ *| HEBREW_CHARSET | \ *| ARABIC_CHARSET | \ *P Windows NT/ 2000 or Thai Windows 3.1 or later: \ *L \ *| THAI_CHARSET | \ *P The OEM_CHARSET value specifies a character set that is operating-system dependent. \ ** Windows 95/98: You can use the DEFAULT_CHARSET value to allow the name and size of a font \ ** to fully describe the logical font. If the specified font name does not exist, a font from \ ** any character set can be substituted for the specified font, so you should use DEFAULT_CHARSET \ ** sparingly to avoid unexpected results. \n \ ** Windows NT/ 2000: DEFAULT_CHARSET is set to a value based on the current system locale. For \ ** example, when the system locale is English (United States), it is set as ANSI_CHARSET. \n \ ** Fonts with other character sets may exist in the operating system. If an application uses a \ ** font with an unknown character set, it should not attempt to translate or interpret strings \ ** that are rendered with that font. \n \ ** This parameter is important in the font mapping process. To ensure consistent results, specify \ ** a specific character set. If you specify a typeface name in the lfFaceName member, make sure \ ** that the lfCharSet value matches the character set of the typeface specified in lfFaceName. to lfCharSet ;M :M SetOutPrecision: ( n1 -- ) \ *G Specifies the output precision. The output precision defines how closely the output must match \ ** the requested font's height, width, character orientation, escapement, pitch, and font type. It can \ ** be one of the following values. \ *L \ *| OUT_CHARACTER_PRECIS Not used. \ *| OUT_DEFAULT_PRECIS | Specifies the default font mapper behavior. | \ *| OUT_DEVICE_PRECIS | Instructs the font mapper to choose a Device font when the system contains multiple fonts with the same name. | \ *| OUT_OUTLINE_PRECIS | Windows NT/ 2000: This value instructs the font mapper to choose from TrueType and other outline-based fonts. | \ *| OUT_RASTER_PRECIS | Instructs the font mapper to choose a raster font when the system contains multiple fonts with the same name. | \ *| OUT_TT_ONLY_PRECIS | Instructs the font mapper to choose from only TrueType fonts. If there are no TrueType fonts installed in the system, the font mapper returns to default behavior. | \ *| OUT_TT_PRECIS | Instructs the font mapper to choose a TrueType font when the system contains multiple fonts with the same name. | \ *P Applications can use the OUT_DEVICE_PRECIS, OUT_RASTER_PRECIS, and OUT_TT_PRECIS values to control \ ** how the font mapper chooses a font when the operating system contains more than one font with a \ ** specified name. For example, if an operating system contains a font named Symbol in raster and TrueType \ ** form, specifying OUT_TT_PRECIS forces the font mapper to choose the TrueType version. Specifying \ ** OUT_TT_ONLY_PRECIS forces the font mapper to choose a TrueType font, even if it must substitute a TrueType \ ** font of another name. to lfOutPrecision ;M :M SetClipPrecision: ( n1 -- ) \ *G Specifies the clipping precision. The clipping precision defines how to clip characters that are partially \ ** outside the clipping region. It can be one or more of the following values. \ *L \ *| CLIP_DEFAULT_PRECIS | Specifies default clipping behavior. | \ *| CLIP_CHARACTER_PRECIS | Not used. | \ *| CLIP_EMBEDDED | You must specify this flag to use an embedded read-only font. | \ *| CLIP_LH_ANGLES | When this value is used, the rotation for all fonts depends on whether the orientation of the coordinate system is left-handed or right-handed. \ *P For more information about the orientation of coordinate systems, see the description of the nOrientation parameter | to lfClipPrecision ;M :M SetQuality: ( n1 -- ) \ *G Specifies the output quality. The output quality defines how carefully the graphics device interface (GDI) must \ ** attempt to match the logical-font attributes to those of an actual physical font. It can be one of the following \ ** values. \ *L \ *| ANTIALIASED_QUALITY | Font is always antialiased if the font supports it and the size of the font is not too small or too large. | \ *| DEFAULT_QUALITY | Appearance of the font does not matter. | \ *| DRAFT_QUALITY | Appearance of the font is less important than when PROOF_QUALITY is used. For GDI raster fonts, scaling is enabled, which means that more font sizes are available, but the quality may be lower. < \ *| NONANTIALIASED_QUALITY | Font is never antialiased. | \ *| PROOF_QUALITY | Character quality of the font is more important than exact matching of the logical-font attributes. | \ *P If neither ANTIALIASED_QUALITY nor NONANTIALIASED_QUALITY is selected, the font is antialiased only if the user chooses \ ** smooth screen fonts in Control Panel. to lfQuality ;M :M SetPitchAndFamily: ( n1 -- ) \ *G Specifies the pitch and family of the font. The two low-order bits specify the pitch of the font and can \ ** be one of the following values. \ *L \ *| DEFAULT_PITCH | \ *| FIXED_PITCH | \ *| VARIABLE_PITCH | \ *P Bits 4 through 7 of the member specify the font family and can be one of the following values. \ *L \ *| FF_DECORATIVE \ *| FF_DONTCARE \ *| FF_MODERN \ *| FF_ROMAN \ *| FF_SCRIPT \ *| FF_SWISS \ *P The proper value can be obtained by using the Boolean OR operator to join one pitch constant with one \ ** family constant. \ *P Font families describe the look of a font in a general way. They are intended for specifying fonts \ ** when the exact typeface desired is not available. The values for font families are as follows. \ *L \ *| FF_DECORATIVE | Novelty fonts. Old English is an example. | \ *| FF_DONTCARE | Don't care or don't know. | \ *| FF_MODERN | Fonts with constant stroke width (monospace), with or without serifs. Monospace fonts are usually modern. Pica, Elite, and CourierNew® are examples. | \ *| FF_ROMAN | Fonts with variable stroke width (proportional) and with serifs. MS® Serif is an example. | \ *| FF_SCRIPT | Fonts designed to look like handwriting. Script and Cursive are examples. | \ *| FF_SWISS | Fonts with variable stroke width (proportional) and without serifs. MS® Sans Serif is an example. | to lfPitchAndFamily ;M :M SetFaceName: ( a1 n1 -- ) \ *G Specifies the typeface name of the font. The length of this string must not exceed 32 characters, including \ ** the null terminator. The EnumFontFamilies function can be used to enumerate the typeface names of all \ ** currently available fonts. If lfFaceName is an empty string, GDI uses the first font that matches the other \ ** specified attributes. lfFaceName LF_FACESIZE erase LF_FACESIZE 1- min lfFaceName swap move ;M :M GetHeight: ( -- n1 ) \ *G Fet the height, in logical units, of the font's character cell or character lfHeight ;M :M GetWidth: ( -- n1 ) \ *G Get the average width, in logical units, of characters in the font lfWidth ;M :M GetEscapement: ( -- n1 ) \ *G Get the angle, in tenths of degrees, between the escapement vector and the x-axis of \ ** the device. The escapement vector is parallel to the base line of a row of text. lfEscapement ;M :M GetOrientation: ( -- n1 ) \ *G Get the angle, in tenths of degrees, between each character's base line and the x-axis of the device. lfOrientation ;M :M GetWeight: ( -- n1 ) \ *G Get the weight of the font lfWeight ;M :M GetItalic: ( -- f1 ) \ *G TRUE if it's an italic font. lfItalic ;M :M GetUnderline: ( -- f1 ) \ *G TRUE if it's a underlined font. lfUnderline ;M :M GetStrikeOut: ( -- f1 ) \ *G TRUE if it's a strikeout font. lfStrikeOut ;M :M GetCharSet: ( -- n1 ) \ *G Get the character set. lfCharSet ;M :M GetOutPrecision: ( -- n1 ) \ *G Get the output precision. lfOutPrecision ;M :M GetClipPrecision: ( -- n1 ) \ *G Get the clipping precision lfClipPrecision ;M :M GetQuality: ( -- n1 ) \ *G Get the output quality. lfQuality ;M :M GetPitchAndFamily: ( -- n1 ) \ *G Get the pitch and family of the font. lfPitchAndFamily ;M :M GetFaceName: ( -- a1 n1 ) \ *G Get the typeface name of the font. lfFaceName LF_FACESIZE 2dup 0 scan nip - ;M :M GetLogfont: ( -- n1 ) \ *G Get the address of the LOGFONT structure LOGFONT ;M :M Create: ( -- f ) \ *G Create a new font. If the current font handle is valid, the font will be destroyed. LOGFONT Call CreateFontIndirect SetHandle: super Valid?: super ;M : Choose ( hWnd -- f ) to hwndOwner &CHOOSEFONT call ChooseFont if Create: self else false then ; :M Choose: ( hWnd -- f ) \ *G Open a dialog to choose a Screen font. If the dialog is closed with OK, the font \ ** will be created. NULL to hDC [ CF_SCREENFONTS CF_INITTOLOGFONTSTRUCT or ] literal to Flags Choose ;M :M ChoosePrinter: ( hWnd hDC -- f ) \ *G Open a dialog to choose a Printer font for the PrinterDC hDC. If the dialog is closed \ ** with OK, the fontwill be created. GetGdiObjectHandle to hDC [ CF_PRINTERFONTS CF_INITTOLOGFONTSTRUCT or ] literal to Flags Choose ;M ;Class \ *G End of gdiFont class module \ *Z --- NEW FILE: gdiDC.f --- \ *D doc\classes\ \ *! gdiDC \ *T gdiDC -- Base device context class \ *Q Version 1.0 \ ** This GDI class library was written and placed in the Public Domain \ ** in 2005 by Dirk Busch \ *S Glossary \ Missing: - WorldTransform support cr .( Loading GDI class library - Device context...) needs gdiBase.f internal external 8 value CHAR-WIDTH \ Width of each character in pixels 14 value CHAR-HEIGHT \ Height of each character in pixels [...1245 lines suppressed...] \ ** PatBlt \n \ ** AngleArc \n \ ** SetMiterLimit \n \ ** GetMiterLimit \n \ ---------------------------------------------------------------------- \ ---------------------------------------------------------------------- :M ClassInit: ( -- ) ClassInit: super 8 to tabwidth DefaultTabs: self ;M ;class \ *G End of gdiDC class module \ *Z --- NEW FILE: gdiWindowDc.f --- \ *D doc\classes\ \ *! gdiWindowDc \ *T gdiWindowDc -- Window device context class \ *Q Version 1.0 \ ** This GDI class library was written and placed in the Public Domain \ ** in 2005 by Dirk Busch \ *S Glossary cr .( Loading GDI class library - Window device context...) needs gdiDC.f internal external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class gdiWindowDC <super gdiDC \ *G Window device context class int hWnd \ handle of the window in which this device context is used :M ClassInit: ( -- ) ClassInit: super 0 to hWnd ;M :M Release: ( -- ) \ *G The Release: method 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. 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 ) to hObject Valid?: super ; :M GetDC: ( hWnd -- f ) \ *G The GetDC method retrieves a handle to a display device context \ ** for the client area of a specified window. SetWindow if hWnd call GetDC else NULL then SetHandle ;M :M GetDCEx: ( hrgnClip flags hWnd -- f ) \ *G The GetDCEx method retrieves a handle to a display device context \ ** 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. \ *P 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. \ *P \i hrgnClip \d 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. \ *P \i flags \d Specifies how the DC is created. This parameter can be one or more of the \ ** following values. \ *P \b DCX_WINDOW \d Returns a DC that corresponds to the window rectangle rather \ ** than the client rectangle. \ *P \b DCX_CACHE \d Returns a DC from the cache, rather than the OWNDC or CLASSDC \ ** window. Essentially overrides CS_OWNDC and CS_CLASSDC. \ *P \b DCX_PARENTCLIP \d 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. \ *P \b DCX_CLIPSIBLINGS \d Excludes the visible regions of all sibling windows above the \ ** window identified by hWnd. \ *P \b DCX_CLIPCHILDREN \d Excludes the visible regions of all child windows below the \ ** window identified by hWnd. \ *P \b DCX_NORESETATTRS \d Does not reset the attributes of this DC to the default attributes \ ** when this DC is released. \ *P \b DCX_LOCKWINDOWUPDATE \d Allows drawing even if there is a LockWindowUpdate call in effect \ ** that would otherwise exclude this window. Used for drawing during \ ** tracking. \ *P \b DCX_EXCLUDERGN \d The clipping region identified by hrgnClip is excluded from the \ ** visible region of the returned DC. \ *P \b DCX_INTERSECTRGN \d The clipping region identified by hrgnClip is intersected with the \ ** visible region of the returned DC. \ *P \b DCX_VALIDATE \d 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. SetWindow if swap hWnd call GetDCEx else NULL then SetHandle ;M :M GetWindowDC: ( hWnd -- f ) \ *G 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. SetWindow if hWnd call GetWindowDC else NULL then SetHandle ;M :M GetDCOrg: ( -- x y ) \ *G 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). Addr: POINT hObject call GetDCOrgEx ?win-error GetX: POINT GetY: POINT ;M ;class \ *G End of gdiWindowDC class module \ *Z Index: gdiStruct.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/gdi/gdiStruct.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** gdiStruct.f 28 Apr 2007 10:18:57 -0000 1.1 --- gdiStruct.f 30 Apr 2007 07:49:27 -0000 1.2 *************** *** 8,11 **** --- 8,13 ---- cr .( Loading GDI class library - Structs...) + needs class + Library COMDLG32.DLL --- NEW FILE: gdiMetafileDc.f --- \ *D doc\classes\ \ *! gdiMetafileDC \ *T gdiMetafileDC -- Metafile device context class \ *Q Version 1.0 \ ** This GDI class library was written and placed in the Public Domain \ ** in 2005 by Dirk Busch \ *S Glossary cr .( Loading GDI class library - Metafile device context...) needs gdiDC.f needs gdiMetafile.f internal external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class gdiMetafileDC <super gdiDC \ *G Metafile device context class RECTANGLE MetaRect gdiMetafile Metafile :M SetRect: ( left top right bottom -- ) \ *G Specify the dimensions (in .01-millimeter units) of the picture to be \ ** stored in the enhanced metafile. SetRect: MetaRect ;M :M ClassInit: ( -- ) ClassInit: super 0 0 10000 10000 SetRect: self ;M :M CalcMetaRect: { left top right bottom hDC \ iWidthMM iHeightMM iWidthPels iHeightPels -- } \ *G Calc the dimensions (in .01-millimeter units) of the picture to be \ ** stored in the enhanced metafile. 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 :M StartRecording: ( hRefDC -- f ) \ *G Start recording of a Metafile GetGdiObjectHandle >r 0 \ lpDescription Addrof: MetaRect \ bounding rectangle 0 \ lpstrFileName r> \ hRefDC call CreateEnhMetaFile dup SetHandle: self 0<> ;M :M StopRecording: ( -- f ) \ *G Stop recording of a Metafile hObject ?dup if call CloseEnhMetaFile dup SetHandle: Metafile 0<> 0 SetHandle: self else false then ;M :M Load: ( addr len -- f ) \ *G Load a metafile from a file StopRecording: self drop Load: Metafile ;M :M Save: ( addr len -- f ) \ *G Save the metafile in a file StopRecording: self drop Save: Metafile ;M :M Destroy: ( -- ) \ *G Destroy the metafile. StopRecording: self drop Destroy: Metafile ;M :M Draw: ( left top right bottom hDestDC -- ) \ *G Play the metafile in a rectangle PlayInRect: Metafile ;M :M GetMetafile: ( -- MetafileObject ) \ *G Return the address of the metafile object used by this class Metafile ;M ;class \ *G End of gdiMetafileDC class module \ *Z --- NEW FILE: gdiBrush.f --- \ *D doc\classes\ \ *! gdiBrush \ *T GdiBrush -- Classes for GDI Brushes. \ *Q Version 1.0 \ ** This GDI class library was written and placed in the Public Domain \ ** in 2005 by Dirk Busch cr .( Loading GDI class library - Brush...) needs gdiBase.f internal external \ ---------------------------------------------------------------------- \ ---------------------------------------------------------------------- internal \ *W <a name="gdiBrush"></a> \ *S gdiBrush class :class gdiBrush <super gdiObject \ *G Base class for all brush objects. \n \ ** This is an internal class of the GDI Class library. Don't use it yourself. gdiPoint origin :M ClassInit: ( -- ) ClassInit: super ;M :M SetOrigin: { xOrg yOrg hdc -- } \ *G Set the brush origin that GDI assigns to the next brush an application selects \ ** into the specified device context. \n \ ** Note: hdc can be the address of a gdiDC class instance or a DC handle. \n \ ** A brush is a bitmap that the system uses to paint the interiors of filled shapes. \n \ ** The brush origin is a pair of coordinates specifying the location of one pixel in \ ** the bitmap. The default brush origin coordinates are (0,0). For horizontal coordinates, \ ** the value 0 corresponds to the leftmost column of pixels; the width corresponds to the \ ** rightmost column. For vertical coordinates, the value 0 corresponds to the uppermost \ ** row of pixels; the height corresponds to the lowermost row. \n \ ** The system automatically tracks the origin of all window-managed device contexts and \ ** adjusts their brushes as necessary to maintain an alignment of patterns on the surface. \ ** The brush origin that is set with this call is relative to the upper-left corner of the \ ** client area. \n \ ** An application should call SetOrigin: after setting the bitmap stretching mode to \ ** HALFTONE by using SetStretchBltMode. This must be done to avoid brush misalignment. \n \ ** Windows NT/ 2000: The system automatically tracks the origin of all window-managed device \ ** contexts and adjusts their brushes as necessary to maintain an alignment of patterns on \ ** the surface. \n \ ** Windows 95/98: Automatic tracking of the brush origin is not supported. Applications must \ ** use the UnrealizeObject, SetBrushOrgEx, and SelectObject functions to align the brush before \ ** using it. \n NULL yOrg xOrg hdc GetGdiObjectHandle call SetBrushOrgEx ?win-error ;M :M GetOrigin: ( hdc -- xOrg yOrg ) \ *G Get the current brush origin for the specified device context. Addr: origin call GetBrushOrgEx 0= if -1 -1 \ error else GetX: origin GetY: origin then ;M :M Create: ( lplb -- f ) \ *G 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. call CreateBrushIndirect SetHandle: super Valid?: super ;M ;class \ *G End of gdiBrush class external \ ---------------------------------------------------------------------- \ ---------------------------------------------------------------------- \ *W <a name="gdiSolidBrush"></a> \ *S gdiSolidBrush class :class gdiSolidBrush <super gdiBrush \ *G Solid brush class \ Color of the brush. gdiCOLORREF Color :M ClassInit: ( -- ) ClassInit: super ;M :M SetRValue: ( r -- ) \ *G Set the red component of the brush color. SetRValue: Color ;M :M SetGValue: ( g -- ) \ *G Set the green component of the brush color. SetGValue: Color ;M :M SetBValue: ( b -- ) \ *G Set the blue component of the brush color. SetBValue: Color ;M :M SetRGB: ( r g b -- ) \ *G Set the red, green and blue component of the brush color. SetRGB: Color ;M :M SetColor: ( colorref -- ) \ *G Set color of the brush. SetColor: Color ;M :M SetSysColor: ( n -- ) \ *G Set the color of the brush to a system color. SetSysColor: Color ;M :M ChooseColor: ( hWnd -- f ) \ *G Open a dialog to choose the color of the brush. Choose: Color ;M :M GetRValue: ( -- r ) \ *G Get the red component of the brush color. GetRValue: Color ;M :M GetGValue: ( -- g ) \ *G Get the green component of the brush color. GetGValue: Color ;M :M GetBValue: ( -- b ) \ *G Get the blue component of the brush color. GetBValue: Color ;M :M GetColor: ( -- colorref ) \ *G Get the color of the brush as a windows COLORREF value. GetColor: Color ;M :M Create: ( -- f ) \ *G Create the brush with the current color. GetColor: color call CreateSolidBrush SetHandle: super Valid?: super ;M ;class \ *G End of gdiSolidBrush class \ ---------------------------------------------------------------------- \ ---------------------------------------------------------------------- \ *W <a name="gdiHatchBrush"></a> \ *S gdiHatchBrush class :class gdiHatchBrush <super gdiSolidBrush \ *G Hatch brush class \ 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 -- ) \ *G Set the style of the brush. Possible values are: \ *L \ *| 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 | to style ;M :M GetStyle: ( -- style ) \ *G Get the style of the brush. Possible return values are: \ *L \ *| 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 | style ;M :M Create: ( -- f ) \ *G Create the brush with the current style and color. GetColor: color Style call CreateHatchBrush SetHandle: super Valid?: super ;M ;class \ *G End of gdiHatchBrush class \ ---------------------------------------------------------------------- \ ---------------------------------------------------------------------- \ *W <a name="gdiPatternBrush"></a> \ *S gdiPatternBrush class :class gdiPatternBrush <super gdiBrush \ *G Pattern brush class. \n \ Bitmap of the brush. int Bitmap :M ClassInit: ( -- ) ClassInit: super 0 to Bitmap ;M :M SetBitmap: ( Bitmap -- ) \ *G Set the Bitmap for the PatternBrush. The Bitmap can be a DIB section bitmap, \ ** which is created by the CreateDIBSection function. to Bitmap ;M :M GetBitmap: ( -- Bitmap ) \ *G Get the Bitmap for the PatternBrush. Bitmap ;M :M Create: ( -- f ) \ *G Creates a logical brush with the specified bitmap pattern. Bitmap ?dup if call CreatePatternBrush SetHandle: super then Valid?: super ;M ;class \ *G End of gdiPatternBrush class \ ---------------------------------------------------------------------- \ DIBPattern brush class \ ---------------------------------------------------------------------- \ *W <a name="gdiDIBPatternBrush"></a> \ *S gdiDIBPatternBrush class :class gdiDIBPatternBrush <super gdiBrush \ *G DIB Pattern brush class :M ClassInit: ( -- ) ClassInit: super ;M :M Create: ( lpPackedDIB iUsage -- f ) \ *G The Create function creates a logical brush that has the pattern specified \ ** by the device-independent bitmap (DIB). \n \ ** lpPackedDIB Pointer to a packed DIB consisting of a BITMAPINFO structure immediately \ ** followed by an array of bytes defining the pixels of the bitmap. \n \ ** 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. \n \ ** Windows NT/ 2000 and Windows 98: Brushes can be created from bitmaps or DIBs \ ** larger than 8 by 8 pixels. \n \ ** 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. \ *L \ *| 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. | call CreateDIBPatternBrushPt SetHandle: super Valid?: super ;M ;class \ *G End of gdiDIBPatternBrush class module \ *Z |
|
From: George H. <geo...@us...> - 2007-04-28 10:19:04
|
Update of /cvsroot/win32forth/win32forth-stc/src/gdi In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13237/win32forth-stc/src/gdi Added Files: gdiBase.f gdiPen.f gdiStruct.f gdiTools.f Log Message: gah:Added some of the gdi functions updated primutil.f with extra utilities needed for GUI and bugfixes/extensions to class.f --- NEW FILE: gdiBase.f --- \ *D doc\classes\ \ *! gdiBase \ *T gdiObject -- Base class for GDI objects \ *Q Version 1.0 \ ** This GDI class library was written and placed in the Public Domain \ ** in 2005 by Dirk Busch \ *P gdiObject is the base class for all GDI objects. This class \ ** contains a single ivar, hObject, that is the (MS Windows) handle for the \ ** GDI object. Since GdiObject is a generic class it should not be used to create \ ** any instances. There will be the following subclasses of gdiObject: \ *W <ul> \ *W <li><a href="gdiPen.htm#gdiPen">gdiPen</a> Class for cosmetic pen's</li> \ *W <li><a href="gdiPen.htm#gdiGeometricPen">gdiGeometricPen</a> Class for geometric pen's</li> \ *W <li><a href="gdiBrush.htm#gdiSolidBrush">gdiSolidBrush</a> Solid brush class</li> \ *W <li><a href="gdiBrush.htm#gdiHatchBrush">gdiHatchBrush</a> Hatch brush class</li> \ *W <li><a href="gdiBrush.htm#gdiPatternBrush">gdiPatternBrush</a> Pattern brush class</li> \ *W <li><a href="gdiBrush.htm#gdiDIBPatternBrush">gdiDIBPatternBrush</a> DIBPattern brush class</li> \ *W <li><a href="gdiFont.htm">gdiFont</a> Class for windows fonts</li> \ *W <li><a href="gdiBitmap.htm">gdiBitmap</a> Class for bitmaps</li> \ *W <li><a href="gdiMetafile.htm">gdiMetafile</a> Class for enhanced metafiles</li> \ *W <li><a href="gdiDC.htm">gdiDC</a> Base device context class</li> \ *W <li><a href="gdiWindowDC.htm">gdiWindowDC</a> Device context class for windows</li> \ *W <li><a href="gdiMetafileDC.htm">gdiMetafileDC</a> Device context class for enhanced metafiles</li> \ *W </ul> \ *P There are some other (old) classes in Win32Forth that are dealing with the GDI: \ *L \ *| ColorObject | Class for color objects | \ *| ExtColorObject | Class for extended color objects | \ *| HatchColorObject | Class for hatch color objects | \ *| Font | Class for fonts | \ *| WinDC | Device context class for windows | \ *| WinPrinter | Device context class for printing | \ *P All old classes are rewritten to use the GDI class library. \ *S Glossary cr .( Loading GDI class library - Base...) needs gdiStruct.f needs gdiTools.f \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Global linked list of gdi objects \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ internal \ List of all GDI objects that are currently defined in the system. VARIABLE gdi-object-link gdi-object-link OFF external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Base class for all GDI Objects \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class gdiObject <super object \ *G gdiObject is the base class for all GDI Object classes. int hObject \ handle of the GDI object :M ZeroHandle: ( -- ) \ *G Clear the handle of the object. \n \ ** If the current handle of the object is valid it will not be destroyed. 0 to hObject ;M :M ClassInit: ( -- ) \ Init the class ClassInit: super ZeroHandle: self \ zero handle gdi-object-link link, \ link into list so we self , \ can send ourself messages ;M :M GetType: ( -- n ) \ *G Get the type of the object. \n \ ** Possible return values are: \ *L \ *| OBJ_BITMAP | Bitmap | \ *| OBJ_BRUSH | Brush | \ *| OBJ_COLORSPACE | Color space | \ *| OBJ_DC | Device context | \ *| OBJ_ENHMETADC | Enhanced metafile DC | \ *| OBJ_ENHMETAFILE | Enhanced metafile | \ *| OBJ_EXTPEN | Extended pen | \ *| OBJ_FONT | Font | \ *| OBJ_MEMDC | Memory DC | \ *| OBJ_METAFILE | Metafile | \ *| OBJ_METADC | Metafile DC | \ *| OBJ_PAL | Palette | \ *| OBJ_PEN | Pen | \ *| OBJ_REGION | Region | hObject call GetObjectType ;M :M GetObject: ( cbBuffer lpvObject -- n ) \ *G Get information for the object. \n \ ** If the function succeeds, and lpvObject is a valid pointer, the return value is \ ** the number of bytes stored into the buffer. \n \ ** If the function succeeds, and lpvObject is NULL, the return value is the number \ ** of bytes required to hold the information the function would store into the buffer. \ ** If the function fails, the return value is zero. hObject 3reverse call GetObject ;M \ check if it's save to destroy the object : Destroy? ( -- f ) GetType: self dup OBJ_PEN = swap dup OBJ_EXTPEN = swap dup OBJ_BRUSH = swap dup OBJ_FONT = swap dup OBJ_BITMAP = swap dup OBJ_REGION = swap OBJ_PAL = or or or or or or ; :M Destroy: ( -- ) \ *G Destroy the object. Destroy? if hObject call DeleteObject drop \ ?win-error then 0 to hObject ;M :M GetHandle: ( -- hObject ) \ *G Get the handle of the object. hObject ;M :M SetHandle: ( hObject -- ) \ *G Set the handle of the object. \n \ ** If the current handle of the object is valid it will be destroyed. Destroy: self to hObject ;M :M Valid?: ( -- f ) \ *G Check if this object is valid. hObject 0<> ;M \ ---------------- INTERNAL SYSTEM FUNCTIONS FOLLOW ---------------- \ The following functions and methods make sure that any gdi objects \ created in your application get reset at system startup, and deleted \ when Win32Forth closes. in-system : trim-gdi-objects ( nfa -- nfa ) dup gdi-object-link full-trim ; forget-chain chain-add trim-gdi-objects in-application : do-objects { method -- } gdi-object-link @ begin dup while dup cell+ @ method execute @ repeat drop ; \ : init-gdi-objects ( -- ) \ clear all handles \ [getmethod] ZeroHandle: GdiObject do-objects ; \ [getmethod] not yet implemented : init-gdi-object ( obj -- ) ZeroHandle: GdiObject ; : init-gdi-objects ( -- ) \ clear all handles ['] init-gdi-object do-objects ; :M destroy-gdi-objects: ( -- ) \ destory this object 0 SetHandle: self ;M : destroy-gdi-object ( obj -- ) \ destroy a GDI object destroy-gdi-objects: GdiObject ; : destroy-gdi-objects ( -- ) \ destroy all GDI objects ['] destroy-gdi-object do-objects ; initialization-chain chain-add init-gdi-objects unload-chain chain-add destroy-gdi-objects ;class \ *G End of gdiBase class \ *S Helper words outside the gdiBase class : ?IsGdiObject ( a1 -- f ) \ w32f \ *G Check if a1 is the address of a GdiObject. >r gdi-object-link @ begin dup while dup cell+ @ r@ = \ match this gdi object? if drop rdrop true EXIT \ leave test, passed then @ repeat drop rdrop false ; : GetGdiObjectHandle { GdiObject -- handle } \ w32f \ *G Check if GdiObject is the address of a valid GdiObject. \ ** If so return the handle of the object. GdiObject ?IsGdiObject if GetHandle: GdiObject else GdiObject then ; in-system (( : .gdi-objects ( -- ) \ w32f sys \ *G Display GDI objects whitch are currently defined. gdi-object-link @ begin dup while dup cell+ @ cell - body> .NAME 12 #tab space 12 ?cr @ repeat drop ; )) in-application \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ A utility word to check that an operation about to be performed is really \ being done on a gdi object, helps prevent horrible crashes \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ in-system : (?GdiCheck) ( a1 -- a1 ) \ w32f sys internal \ *G Verify if a1 is the address of a GdiObject. \ ** If a1 isn't the address of a GdiObject the application will be aborted. dup ?IsGdiObject 0= if \ forth-io .rstack true Abort" This is not a GDI Object!" then ; in-application : ?GdiCheck ( a1 -- a1 ) \ w32f \ *G Verify if a1 is the address of a GdiObject. \ *P If a1 isn't the address of a GdiObject and the error checking is enabled \ ** the application will be aborted. \ *P NOTE: \i ?GdiCheck \d does nothing in turnkey applications, it's for debugging only. \ TURNKEYED? ?win-error-enabled 0= or ?EXIT \ leave if error checking is not enabled \in-system-ok (?GdiCheck) ; module \ *Z --- NEW FILE: gdiTools.f --- \ *! gdiTools \ *T GdiTools -- Helper words for the GDI class library \ *Q Version 1.0 \ ** This GDI class library was written and placed in the Public Domain \ ** in 2005 by Dirk Busch \ *S Glossary cr .( Loading GDI class library - Tools...) internal external in-application [undefined] S-REVERSE [IF] \ from toolset.f CODE S-REVERSE ( n[k]..2 1 0 k -- 0 1 2..n[k] ) \ w32f \ *G Reverse n items on stack \n \ ** Usage: 1 2 3 4 5 5 S_REVERSE ==> 5 4 3 2 1 lea ecx, -4 [ebp] \ ecx points 4 under top of stack lea eax, 4 [ecx] [eax*4] \ eax points 4 over stack \ bump pointers, if they overlap, stop @@1: sub eax, # 4 \ adjust top add ecx, # 4 \ adjust bottom cmp ecx, eax \ compare jae short @@2 \ ecx passing eax, so exit \ rotate a pair \ xor a,b xor b,a xor a,b swaps a and b mov edx, 0 [eax] \ bottom to edx xor 0 [ecx], edx \ exchange top and edx xor edx, 0 [ecx] xor 0 [ecx], edx mov 0 [eax], edx \ edx to bottom jmp short @@1 \ next pair @@2: mov eax, 0 [ebp] \ tos lea ebp, 4 [ebp] next c; [then] [undefined] 3reverse [if] : 3reverse ( n1 n2 n3 -- n3 n2 n1 ) \ w32f \ *G Reverse 3 items on stack 3 S-REVERSE ; [then] [undefined] 4reverse [if] : 4reverse ( n1 n2 n3 n4 -- n4 n3 n2 n1 ) \ w32f \ *G Reverse 4 items on stack 4 S-REVERSE ; [then] [undefined] 5reverse [if] : 5reverse ( n1 n2 n3 n4 n5 -- n5 n4 n3 n2 n1 ) \ w32f \ *G Reverse 5 items on stack 5 S-REVERSE ; [then] [undefined] 6reverse [if] : 6reverse ( n1 n2 n3 n4 n5 n6 -- n6 n5 n4 n3 n2 n1 ) \ w32f \ *G Reverse 6 items on stack 6 S-REVERSE ; [then] [undefined] 8reverse [if] : 8reverse ( n1 n2 n3 n4 n5 n6 n7 n8 -- n8 n7 n6 n5 n4 n3 n2 n1 ) \ w32f \ *G Reverse 8 items on stack 8 S-REVERSE ; [then] module \ *Z --- NEW FILE: gdiStruct.f --- \ *D doc\classes\ \ *! gdiStruct \ *T gdiStruct -- Wrapper classes for GDI structs. \ *Q Version 1.0 \ ** This GDI class library was written and placed in the Public Domain \ ** in 2005 by Dirk Busch cr .( Loading GDI class library - Structs...) Library COMDLG32.DLL internal create CustomColors 64 allot \ hold the userdefined custom colors \ init custom colors 0xE6FFFF CustomColors ! 0xFFE6FF CustomColors 0x04 + ! 0xFFFFE6 CustomColors 0x08 + ! 0xFFE6E6 CustomColors 0x0C + ! 0xE6FFE6 CustomColors 0x10 + ! 0xE6E6FF CustomColors 0x14 + ! 0xC8F0F0 CustomColors 0x18 + ! 0xF0C8F0 CustomColors 0x1C + ! 0xF0F0C8 CustomColors 0x20 + ! 0xF0C8C8 CustomColors 0x24 + ! 0xC8F0C8 CustomColors 0x28 + ! 0xC8C8F0 CustomColors 0x2C + ! 0xF0F0F0 CustomColors 0x30 + ! 0xE6E6E6 CustomColors 0x34 + ! 0xF4FFFF CustomColors 0x38 + ! 0xFFFFF4 CustomColors 0x3C + ! external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ *W <a name="gdiPOINT"></a> \ *S gdiPOINT class :class gdiPOINT <super object \ *G Wrapper class for a POINT struct. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ Record: &POINT int x int y ;RecordSize: sizeof(POINT) :M ClassInit: ( -- ) ClassInit: super 0 to x 0 to y ;M :M GetX: ( -- x ) \ *G Get the x value of the point. x ;M :M GetY: ( -- y ) \ *G Get the y value of the point. y ;M :M SetX: ( x -- ) \ *G Set the x value of the point. to x ;M :M SetY: ( y -- ) \ *G Get the y value of the point. to y ;M :M Addr: ( -- addr ) \ *G Get the address of the point struct. &POINT ;M :M Size: ( -- size ) \ *G Get the site of the point struct sizeof(POINT) ;M ;class \ *G End of gdiPOINT class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ *W <a name="gdiCOLORREF"></a> \ *S gdiCOLORREF class :class gdiCOLORREF <super object \ *G Wrapper class for a COLORREF struct. \ *P A COLORREF value is used to specify an RGB color. \ *P When specifying an explicit RGB color, the COLORREF value has the following \ ** hexadecimal form: 0x00bbggrr \n \ ** The low-order byte contains a value for the relative intensity of red; \ ** the second byte contains a value for green; and the third byte contains a \ ** value for blue. The high-order byte must be zero. The maximum value for a \ ** single byte is 0xFF. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ Record: &COLORREF byte r byte g byte b byte reserved ;RecordSize: sizeof(COLORREF) Record: &CHOOSECOLOR int lStructSize int hwndOwner int hInstance int rgbResult int lpCustColors int Flags int lCustData int lpfnHook int lpTemplateName ;RecordSize: sizeof(CHOOSECOLOR) :M ClassInit: ( -- ) ClassInit: super \ init &COLOR record 0 to r 0 to g 0 to b 0 to reserved \ init &CHOOSECOLOR record sizeof(CHOOSECOLOR) to lStructSize CustomColors to lpCustColors [ CC_ANYCOLOR CC_FULLOPEN or CC_RGBINIT or ] literal to Flags null to hwndOwner null to hInstance 0 to rgbResult 0 to lCustData null to lpfnHook null to lpTemplateName ;M :M SetRValue: ( r -- ) \ *G Set the red value of the color to r ;M :M SetGValue: ( g -- ) \ *G Set the green value of the color to g ;M :M SetBValue: ( b -- ) \ *G Set the blue value of the color to b ;M :M GetRValue: ( -- r ) \ *G Get the red value of the color r ;M :M GetGValue: ( -- g ) \ *G Get the green value of the color g ;M :M GetBValue: ( -- b ) \ *G Get the blue value of the color b ;M :M SetColor: ( colorref -- ) \ *G Set the color 0x00ffffff and &COLORREF ! ;M :M SetSysColor: ( n -- ) \ *G Set a system color. Possible values are: \ *L \ *| COLOR_3DDKSHADOW | Dark shadow for three-dimensional display elements. | \ *| COLOR_3DFACE, COLOR_BTNFACE | Face color for three-dimensional display elements and for dialog box backgrounds. | \ *| COLOR_3DHILIGHT | Highlight color for three-dimensional display elements (for edges facing the light source.) | \ *| COLOR_3DHIGHLIGHT | Highlight color for three-dimensional display elements (for edges facing the light source.) | \ *| COLOR_BTNHILIGHT | Highlight color for three-dimensional display elements (for edges facing the light source.) | \ *| COLOR_BTNHIGHLIGHT | Highlight color for three-dimensional display elements (for edges facing the light source.) | \ *| COLOR_3DLIGHT | Light color for three-dimensional display elements (for edges facing the light source.) | \ *| COLOR_3DSHADOW, COLOR_BTNSHADOW | Shadow color for three-dimensional display elements (for edges facing away from the light source). | \ *| COLOR_ACTIVEBORDER | Active window border. | \ *| COLOR_ACTIVECAPTION | Active window title bar. Windows 98, Windows 2000: Specifies the left side color in the color gradient of an active window's title bar if the gradient effect is enabled. | \ *| COLOR_APPWORKSPACE | Background color of multiple document interface (MDI) applications. | \ *| COLOR_BACKGROUND, COLOR_DESKTOP | Desktop. | \ *| COLOR_BTNTEXT | Text on push buttons. | \ *| COLOR_CAPTIONTEXT | Text in caption, size box, and scroll bar arrow box. | \ *| COLOR_GRADIENTACTIVECAPTION | Windows 98, Windows 2000: Right side color in the color gradient of an active window's title bar. \ *| COLOR_ACTIVECAPTION | Windows 98, Windows 2000: specifies the left side color. \ *| COLOR_GRADIENTINACTIVECAPTION | Windows 98, Windows 2000: Right side color in the color gradient of an inactive window's title bar. \ *| COLOR_INACTIVECAPTION | Windows 98, Windows 2000: specifies the left side color. | \ *| COLOR_GRAYTEXT | Grayed (disabled) text. This color is set to 0 if the current display driver does not support a solid gray color. | \ *| COLOR_HIGHLIGHT | Item(s) selected in a control. | \ *| COLOR_HIGHLIGHTTEXT | Text of item(s) selected in a control. | \ *| COLOR_HOTLIGHT | Windows 98, Windows 2000: Color for a hot-tracked item. Single clicking a hot-tracked item executes the item. | \ *| COLOR_INACTIVEBORDER | Inactive window border. | \ *| COLOR_INACTIVECAPTION | Inactive window caption. Windows 98, Windows 2000: Specifies the left side color in the color gradient of an inactive window's title bar if the gradient effect is enabled. | \ *| COLOR_INACTIVECAPTIONTEXT | Color of text in an inactive caption. | \ *| COLOR_INFOBK | Background color for tooltip controls. | \ *| COLOR_INFOTEXT | Text color for tooltip controls. | \ *| COLOR_MENU | Menu background. | \ *| COLOR_MENUTEXT | Text in menus. | \ *| COLOR_SCROLLBAR | Scroll bar gray area. | \ *| COLOR_WINDOW | Window background. | \ *| COLOR_WINDOWFRAME | Window frame. | \ *| COLOR_WINDOWTEXT | Text in windows. | call GetSysColor &COLORREF ! ;M :M GetColor: ( -- colorref ) \ *G Get the color &COLORREF @ ;M :M SetRGB: ( r g b -- ) \ *G Set the red, green and blue values of the color SetBValue: self SetGValue: self SetRValue: self ;M :M Addr: ( -- addr ) \ *G Get the address of the COLORREF struct &COLORREF ;M :M Size: ( -- size ) \ *G Get the size of the COLORREF struct sizeof(COLORREF) ;M :M Choose: ( hWnd -- f ) \ *G Open the windows dialog for choosing a color. to hwndOwner GetColor: self to rgbResult &CHOOSECOLOR call ChooseColor IF rgbResult SetColor: self true else false then ;M \ return address and length of the user defined custom colors :M CustomColors: ( -- addr len ) \ *G Get the address and length (in cells) of the CustomColors array \ ** used by Choose: CustomColors 64 ;M ;class \ *G End of gdiCOLORREF class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ *W <a name="gdiRGBQUAD"></a> \ *S gdiRGBQUAD class :class gdiRGBQUAD <super gdiCOLORREF \ *G Wrapper class for a RGBQUAD struct \ *P The RGBQUAD structure describes a color consisting of relative \ ** intensities of red, green, and blue. \ *P The bmiColors member of the BITMAPINFO structure consists of an array \ ** of RGBQUAD structures. \ *P Note: This class doesn't have any private methods. For a description \ ** of the methods see the \i gdiCOLORREF \d class. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :M ClassInit: ( -- ) ClassInit: super ;M ;class \ *G End of gdiRGBQUAD class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ *W <a name="gdiSIZE"></a> \ *S gdiSIZE class :class gdiSIZE <super object \ *G Wrapper class for a SIZE struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ Record: &SIZE int cx int cy ;RecordSize: sizeof(SIZE) :M ClassInit: ( -- ) ClassInit: super 0 to cx 0 to cy ;M :M GetX: ( -- x ) \ *G Get the x value cx ;M :M GetY: ( -- y ) \ *G Get the y value cy ;M :M SetX: ( x -- ) \ *G Set the x value to cx ;M :M SetY: ( y -- ) \ *G Set the y value to cy ;M :M Addr: ( -- addr ) \ *G Get the address of the SIZE struct &SIZE ;M :M Size: ( -- size ) \ *G Get the size of the SIZE struct sizeof(SIZE) ;M ;class \ *G End of gdiSIZE class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ *W <a name="gdiTEXTMETRIC"></a> \ *S gdiTEXTMETRIC class :class gdiTEXTMETRIC <super object \ *G Wrapper class for a TEXTMETRIC struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ Record: &TEXTMETRIC int tmHeight int tmAscent int tmDescent int tmInternalLeading int tmExternalLeading int tmAveCharWidth int tmMaxCharWidth int tmWeight int tmOverhang int tmDigitizedAspectX int tmDigitizedAspectY byte tmFirstChar byte tmLastChar byte tmDefaultChar byte tmBreakChar byte tmItalic byte tmUnderlined byte tmStruckOut byte tmPitchAndFamily byte tmCharSet ;RecordSize: sizeof(TEXTMETRIC) :M ClassInit: ( -- ) ClassInit: super &TEXTMETRIC sizeof(TEXTMETRIC) erase ;M :M SetHeight: ( n -- ) \ *G to tmHeight ;M :M SetAscent: ( n -- ) \ *G to tmAscent ;M :M SetDescent: ( n -- ) \ *G to tmDescent ;M :M SetInternalLeading: ( n -- ) \ *G to tmInternalLeading ;M :M SetExternalLeading: ( n -- ) \ *G to tmExternalLeading ;M :M SetAveCharWidth: ( n -- ) \ *G to tmAveCharWidth ;M :M SetMaxCharWidth: ( n -- ) \ *G to tmMaxCharWidth ;M :M SetWeight: ( n -- ) \ *G to tmWeight ;M :M SetOverhang: ( n -- ) \ *G to tmOverhang ;M :M SetDigitizedAspectX: ( n -- ) \ *G to tmDigitizedAspectX ;M :M SetDigitizedAspectY: ( n -- ) \ *G to tmDigitizedAspectY ;M :M SetFirstChar: ( n -- ) \ *G to tmFirstChar ;M :M SetLastChar: ( n -- ) \ *G to tmLastChar ;M :M SetDefaultChar: ( n -- ) \ *G to tmDefaultChar ;M :M SetBreakChar: ( n -- ) \ *G to tmBreakChar ;M :M SetItalic: ( n -- ) \ *G to tmItalic ;M :M SetUnderlined: ( n -- ) \ *G to tmUnderlined ;M :M SetStruckOut: ( n -- ) \ *G to tmStruckOut ;M :M SetPitchAndFamily: ( n -- ) \ *G to tmPitchAndFamily ;M :M SetCharSet: ( n -- ) \ *G to tmCharSet ;M :M GetHeight: ( -- n ) \ *G tmHeight ;M :M GetAscent: ( -- n ) \ *G tmAscent ;M :M GetDescent: ( -- n ) \ *G tmDescent ;M :M GetInternalLeading: ( -- n ) \ *G tmInternalLeading ;M :M GetExternalLeading: ( -- n ) \ *G tmExternalLeading ;M :M GetAveCharWidth: ( -- n ) \ *G tmAveCharWidth ;M :M GetMaxCharWidth: ( -- n ) \ *G tmMaxCharWidth ;M :M GetWeight: ( -- n ) \ *G tmWeight ;M :M GetOverhang: ( -- n ) \ *G tmOverhang ;M :M GetDigitizedAspectX: ( -- n ) \ *G tmDigitizedAspectX ;M :M GetDigitizedAspectY: ( -- n ) \ *G tmDigitizedAspectY ;M :M GetFirstChar: ( -- n ) \ *G tmFirstChar ;M :M GetLastChar: ( -- n ) \ *G tmLastChar ;M :M GetDefaultChar: ( -- n ) \ *G tmDefaultChar ;M :M GetBreakChar: ( -- n ) \ *G tmBreakChar ;M :M GetItalic: ( -- n ) \ *G tmItalic ;M :M GetUnderlined: ( -- n ) \ *G tmUnderlined ;M :M GetStruckOut: ( -- n ) \ *G tmStruckOut ;M :M GetPitchAndFamily: ( -- n ) \ *G tmPitchAndFamily ;M :M GetCharSet: ( -- n ) \ *G tmCharSet ;M :M Addr: ( -- addr ) &TEXTMETRIC ;M \ *G Get the address of the TEXTMETRIC struct. :M Size: ( -- size ) sizeof(TEXTMETRIC) ;M \ *G Get the size of the TEXTMETRIC struct. ;class \ *G End of gdiTEXTMETRIC class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ The LOGPEN structure defines the style, width, and color of a pen. \ The CreatePenIndirect function uses the LOGPEN structure. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ :struct LOGPEN \ UINT lopnStyle \ int lopnWidth \ int lopnReserved \ COLORREF lopnColor \ ;struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ The LOGBRUSH structure defines the style, color, and pattern of a physical \ brush. It is used by the CreateBrushIndirect and ExtCreatePen functions. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ :struct LOGBRUSH \ UINT lbStyle \ COLORREF lbColor \ LONG lbHatch \ ;struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ BITMAP struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ :struct BITMAP \ LONG bmType \ Specifies the bitmap type. This member must be zero. \ LONG bmWidth \ Specifies the width, in pixels, of the bitmap. \ \ The width must be greater than zero. \ LONG bmHeight \ Specifies the height, in pixels, of the bitmap. \ \ The height must be greater than zero. \ LONG bmWidthBytes \ Specifies the number of bytes in each scan line. \ \ This value must be divisible by 2, because the system \ \ assumes that the bit values of a bitmap form an array \ \ that is word aligned. \ WORD bmPlanes \ Specifies the count of color planes. \ WORD bmBitsPixel \ Specifies the number of bits required to indicate the \ \ color of a pixel. \ LPVOID bmBits \ Pointer to the location of the bit values for the bitmap. \ \ The bmBits member must be a long pointer to an array of \ \ character (1-byte) values. \ ;struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ BITMAPINFOHEADER struct \ \ The BITMAPINFOHEADER structure contains information about the dimensions \ and color format of a DIB. \ \ Applications developed for Windows NT 4.0 and Windows 95 may use the \ BITMAPV4HEADER structure. Applications developed for Windows 2000 and \ Windows 98 may use the BITMAPV5HEADER structure for increased functionality. \ However, these can be used only in the CreateDIBitmap function. \ \ NOTE: BITMAPV4HEADER and BITMAPV5HEADER are not supprted !!! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ :struct BITMAPINFOHEADER \ DWORD biSize \ LONG biWidth \ LONG biHeight \ WORD biPlanes \ WORD biBitCount \ DWORD biCompression \ DWORD biSizeImage \ LONG biXPelsPerMeter \ LONG biYPelsPerMeter \ DWORD biClrUsed \ DWORD biClrImportant \ ;struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ENHMETAHEADER struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ :struct ENHMETAHEADER \ DWORD iType \ DWORD nSize \ RECTL rclBounds \ RECTL rclFrame \ DWORD dSignature \ DWORD nVersion \ DWORD nBytes \ DWORD nRecords \ WORD nHandles \ WORD sReserved \ DWORD nDescription \ DWORD offDescription \ DWORD nPalEntries \ SIZEL szlDevice \ SIZEL szlMillimeters \ DWORD cbPixelFormat \ DWORD offPixelFormat \ DWORD bOpenGL \ SIZEL szlMicrometers \ ;struct module \ *Z --- NEW FILE: gdiPen.f --- \ *D doc\classes\ \ *! gdiPen \ *T GdiPen -- Class for GDI Pens \ *Q Version 1.0 \ ** This GDI class library was written and placed in the Public Domain \ ** in 2005 by Dirk Busch \ TODO: finish gdiGeometricPen class cr .( Loading GDI class library - Pen...) needs gdiBase.f internal external \ ---------------------------------------------------------------------- \ ---------------------------------------------------------------------- \ *W <a name="gdiPen"></a> \ *S gdiPen class :class gdiPen <super gdiObject \ *G Class for cosmetic pen's \ Syle of the pen. int Style \ Width of the pen, in logical units. If Width is zero, the pen is a single pixel \ wide, regardless of the current transformation. int Width \ Color of the pen. gdiCOLORREF Color :M ClassInit: ( -- ) \ *G Init the class ClassInit: super PS_SOLID to Style 1 to Width ;M :M SetStyle: ( style -- ) \ *G Set Syle of the pen. Possible values are: \ *L \ *| PS_SOLID | The pen is solid. | \ *| PS_DASH | The pen is dashed. This style is valid only when the pen width is one or less in device units. | \ *| PS_DOT | The pen is dotted. This style is valid only when the pen width is one or less in device units. | \ *| PS_DASHDOT | The pen has alternating dashes and dots. This style is valid only when the pen width is one or less in device units. | \ *| PS_DASHDOTDOT | The pen has alternating dashes and double dots. This style is valid only when the pen width is one or less in device units. | \ *| PS_NULL | The pen is invisible. | \ *| PS_INSIDEFRAME | The pen is solid. When this pen is used the dimensions of the figure are shrunk so that it fits entirely in the bounding rectangle, taking into account the width of the pen. Only for geometric pens. | to style ;M :M SetWidth: ( width -- ) \ *G Set the width of the pen in logical units. If Width is zero, the pen is a single pixel \ ** wide, regardless of the current transformation. 0 max to width ;M :M SetRValue: ( r -- ) \ *G Set the red component of the pen color. SetRValue: Color ;M :M SetGValue: ( g -- ) \ *G Set the green component of the pen color. SetGValue: Color ;M :M SetBValue: ( b -- ) \ *G Set the blue component of the pen color. SetBValue: Color ;M :M SetRGB: ( r g b -- ) \ *G Set the red, green and blue component of the pen color. SetRGB: Color ;M :M SetColor: ( colorref -- ) \ *G Set color of the pen. SetColor: Color ;M :M SetSysColor: ( n -- ) \ *G Set the color of the pen to a system color. SetSysColor: Color ;M :M ChooseColor: ( hWnd -- f ) \ *G Open a dialog to choose the color of the pen. Choose: Color ;M :M GetStyle: ( -- style ) \ *G Get Syle of the pen. Possible values are: \ *L \ *| PS_SOLID | The pen is solid. | \ *| PS_DASH | The pen is dashed. This style is valid only when the pen width is one or less in device units. | \ *| PS_DOT | The pen is dotted. This style is valid only when the pen width is one or less in device units. | \ *| PS_DASHDOT | The pen has alternating dashes and dots. This style is valid only when the pen width is one or less in device units. | \ *| PS_DASHDOTDOT | The pen has alternating dashes and double dots. This style is valid only when the pen width is one or less in device units. | \ *| PS_NULL | The pen is invisible. | \ *| PS_INSIDEFRAME | The pen is solid. When this pen is used the dimensions of the figure are shrunk so that it fits entirely in the bounding rectangle, taking into account the width of the pen. This applies only to geometric pens. | style ;M :M GetWidth: ( -- width ) \ *G Get the width of the pen in logical units. If the width is zero, the pen is a single pixel \ ** wide, regardless of the current transformation. width ;M :M GetRValue: ( -- r ) \ *G Get the red component of the pen color. GetRValue: Color ;M :M GetGValue: ( -- g ) \ *G Get the green component of the pen color. GetGValue: Color ;M :M GetBValue: ( -- b ) \ *G Get the blue component of the pen color. GetBValue: Color ;M :M GetColor: ( -- colorref ) \ *G Get the color of the pen as a windows COLORREF value. GetColor: Color ;M :M Create: ( -- f ) \ *G Create the pen with the current style, color and width. GetColor: color width style call CreatePen SetHandle: super Valid?: super ;M :M CreateIndirect: ( pLogpen -- f ) \ *G The CreateIndirect function creates a logical cosmetic pen that \ ** has the style, width, and color specified in a structure. dup @ SetStyle: self dup cell+ @ SetWidth: self dup 3 cells + @ SetColor: self call CreatePenIndirect SetHandle: super Valid?: super ;M ;class \ *G End of class \ ---------------------------------------------------------------------- \ ---------------------------------------------------------------------- \ *W <a name="gdiGeometricPen"></a> \ *S gdiGeometricPen class :class gdiGeometricPen <super gdiObject \ *G Class for geometric pen's \n \ ** Note: this class isn't implemented yet :M ClassInit: ( -- ) \ *G Init the class ClassInit: super ;M ;class \ *G End of class module \ *Z |
|
From: George H. <geo...@us...> - 2007-04-28 10:19:03
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13237/win32forth-stc/src Modified Files: Class.f primutil.f Log Message: gah:Added some of the gdi functions updated primutil.f with extra utilities needed for GUI and bugfixes/extensions to class.f Index: primutil.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v retrieving revision 1.26 retrieving revision 1.27 diff -C2 -d -r1.26 -r1.27 *** primutil.f 24 Apr 2007 09:13:14 -0000 1.26 --- primutil.f 28 Apr 2007 10:18:56 -0000 1.27 *************** *** 54,57 **** --- 54,58 ---- : dbg ' execute ; immediate \ *** to be done *** : ?COMP ; immediate \ *** to be done *** + ' drop alias ?win-error \ ------------------------------------------------------------------------ *************** *** 138,141 **** --- 139,154 ---- swap t|Cl = or ; + defer \n->crlf + + : _\n->crlf ( a1 n1 -- ) \ parse "\n" occurances, change to CRLF's + begin [char] \ scan dup \ found a '\' char + while over 1+ c@ [char] n = \ followed by 'n' + if over 13 swap c! \ replace with CR + over 10 swap 1+ c! \ replace with LF + then 1 /string \ else skip '\' char + repeat 2drop ; + + ' _\n->crlf is \n->crlf \ link into kernel deferred word + \ Moved to user area to make asciiz thread safe gah 28jun04 MAXSTRING newuser z-buf *************** *** 283,286 **** --- 296,330 ---- \ ------------------------------------------------------------------------ + \ Needed by dialogs and menus + \ ------------------------------------------------------------------------ + + \ ,"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 !!! + source >in @ /string + [char] " scan 1 /string \ skip past first quote + 2dup [char] " scan \ upto next quote + 2dup 2>r nip - \ parse out the string + "CLIP" dup>r + 2dup \n->crlf \ fix newlines + 2dup [char] \ scan 2dup 2>r nip - \ leading part of string + here place \ save in BNAME + 2r> + -IF over 1+ c@ upc [char] T = + IF 9 here c+place + 2 /string here +place + r> 1- >r + ELSE here +place + THEN + ELSE 2drop + THEN + r> 1+ allot + 0 c, \ null terminate name + source nip 2r> 1 /string nip - >in ! \ adjust >IN + ; + + \ ------------------------------------------------------------------------ \ Often used \ ------------------------------------------------------------------------ Index: Class.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/Class.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** Class.f 25 Apr 2007 09:41:53 -0000 1.2 --- Class.f 28 Apr 2007 10:18:56 -0000 1.3 *************** *** 252,255 **** --- 252,269 ---- in-system + \ Temporary fix for ?isLocal to work + tloc ' local0 >name n>tfa c! + tloc ' local1 >name n>tfa c! + tloc ' local2 >name n>tfa c! + tloc ' local3 >name n>tfa c! + tloc ' local4 >name n>tfa c! + tloc ' local5 >name n>tfa c! + tloc ' local6 >name n>tfa c! + tloc ' local7 >name n>tfa c! + tloc ' local8 >name n>tfa c! + tloc ' local9 >name n>tfa c! + tloc ' local10 >name n>tfa c! + tloc ' local11 >name n>tfa c! + : [self] ( -- ) true abort" Use only for self-reference to object" ; immediate *************** *** 259,264 **** --- 273,280 ---- : ?isValue ( cfa -- f ) >name n>tfa c@ tVal = ; + : ?isLocal ( cfa -- f ) >name n>tfa c@ tLoc = ; + : ?isVect ( cfa -- f ) >name n>tfa c@ dup tVal = *************** *** 412,416 **** dup>r IDX-HDR reserve \ allot space for indexed data r> IFA @ 0 ITRAV \ init instance variables ! ( ClassInit ) ; \ send CLASSINIT: message : (|Build) ( #elems ^class OR ^class -- ) \ Build an instance of a class --- 428,432 ---- dup>r IDX-HDR reserve \ allot space for indexed data r> IFA @ 0 ITRAV \ init instance variables ! ClassInit ; \ send CLASSINIT: message : (|Build) ( #elems ^class OR ^class -- ) \ Build an instance of a class *************** *** 788,792 **** THEN State @ ! IF POSTPONE (Defer) R> , ELSE R> swap Find-Method execute THEN ; --- 804,808 ---- THEN State @ ! IF r> postpone literal POSTPONE (Defer) ELSE R> swap Find-Method execute THEN ; *************** *** 1116,1130 **** \ -------------------- Instance Variables -------------------- ! (( : byte ( -<name>- ) \ W32F Class \ *G Byte (8bit) size instance variable. ! header ! (ivc@) , ! ^Class DFA @ , ! (ivc!) , ! (ivc+!) , ! 8 bitmax \ verify & set bit field finished & new max ! 1 class-allot ; in-previous --- 1132,1156 ---- \ -------------------- Instance Variables -------------------- ! 20 constant TByte ! ! : DoByte ! does> @ self + C@ ; ! : byte ( -<name>- ) \ W32F Class \ *G Byte (8bit) size instance variable. ! \ header ! \ (ivc@) , ! \ ^Class DFA @ , ! \ (ivc!) , ! \ (ivc+!) , ! \ 8 bitmax \ verify & set bit field finished & new max ! \ 1 class-allot ; ! Create ^Class dfa @ , ! 1 class-allot ! DoByte ! tByte tfa! ; ! + (( in-previous *************** *** 1239,1245 **** : (classto) ( n -<value>- -- ) >in @ ^class if bl word count ^class (search-self) ! ?dup if dup n>tfa c@ tint = if name>xt nip nip >body @ postpone ^base postpone literal postpone + postpone ! ! exit else drop then then then >in ! oldto ; ' (classto) compiles-for to --- 1265,1273 ---- : (classto) ( n -<value>- -- ) >in @ ^class if bl word count ^class (search-self) ! ?dup if dup n>tfa c@ dup tint = if drop name>xt nip nip >body @ postpone ^base postpone literal postpone + postpone ! ! exit then tbyte = if name>xt nip nip ! >body @ postpone ^base postpone literal postpone + postpone c! ! exit then drop then then >in ! oldto ; ' (classto) compiles-for to *************** *** 1251,1255 **** ?dup if dup n>tfa c@ tint = if name>xt nip nip >body @ postpone ^base postpone literal postpone + postpone +! ! exit else drop then then then >in ! old+to ; ' (class+to) compiles-for +to --- 1279,1283 ---- ?dup if dup n>tfa c@ tint = if name>xt nip nip >body @ postpone ^base postpone literal postpone + postpone +! ! exit then drop then then >in ! old+to ; ' (class+to) compiles-for +to |
|
From: George H. <geo...@us...> - 2007-04-28 10:16:36
|
Update of /cvsroot/win32forth/win32forth-stc/src/gdi In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv12816/gdi Log Message: Directory /cvsroot/win32forth/win32forth-stc/src/gdi added to the repository |
|
From: George H. <geo...@us...> - 2007-04-28 10:12:52
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv12016/win32forth/src Modified Files: Menu.f Log Message: gah:Added dependency Index: Menu.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Menu.f,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** Menu.f 29 Aug 2005 15:56:27 -0000 1.4 --- Menu.f 28 Apr 2007 10:12:49 -0000 1.5 *************** *** 9,12 **** --- 9,14 ---- only forth also definitions + needs GdiTools + INTERNAL \ internal definitions start here |
1040 messages has been excluded from this view by a project administrator.
