Menu
▾
▴
win32forth-cvs
|
From: Dirk B. <db...@us...> - 2006-09-23 10:18:41
|
Update of /cvsroot/win32forth/win32forth-stc/src/console In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv19498/src/console Added Files: CONSOLE.F Console2.f KEYBOARD.F LINEEDIT.F Log Message: Proted the latest Console-code and the LineEditor. --- NEW FILE: Console2.f --- \ $Id: Console2.f,v 1.1 2006/09/23 10:18:34 dbu_de Exp $ \ File: Console2.f \ Author: Dirk Busch \ Created: November 9th, 2003 - 10:32 dbu \ Updated: November 9th, 2003 - 10:32 dbu \ \ more Win32Forth Terminal I/O (Moved here from Primutil.f ) \ It couldn't be moved into Console.f because 'mouse-chain' must be defined \ before this. cr .( Loading... Console I/O Part 2) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ new definition of key to support minimal mouse down events \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 0 value mousex 0 value mousey 0 value mouseflags (( MOUSEFLAGS info: 3 both buttons, currently assigned to abort 1 left button 9 control left button 13 control shift left mouse button 5 shift left mouse button 2 right button 14 control shift right mouse button 10 control right mouse button 6 shift right mouse button )) defer do-mabort 0 value mkstlin \ hold the status of the current marked console text 0 value mkstcol 0 value mkedlin 0 value mkedcol 0 value mkorlin 0 value mkorcol : mark-start ( -- ) \ set a new start of marked console text mousex charWH >r / to mkstcol mousey r> / getrowoff + to mkstlin mousex charWH >r / to mkedcol mousey r> / getrowoff + to mkedlin mkstlin to mkorlin mkstcol to mkorcol mkstlin mkstcol mkedlin mkedcol markconsole ; : mark-end { \ lin col -- } \ set a new end of marked console text mousex charWH >r / to col mousey r> / getrowoff + to lin lin mkorlin = \ same line but earlier in line col mkorcol <= and lin mkorlin < or \ or on an earlier line if lin to mkstlin col to mkstcol mkorlin to mkedlin mkorcol to mkedcol else lin to mkedlin col to mkedcol mkorlin to mkstlin mkorcol to mkstcol then mkstlin mkstcol mkedlin mkedcol markconsole ; : mark-all ( -- ) \ makr all console text 0 to mkstlin 0 to mkstcol 0 to mkedcol getxy nip getrowoff + 1+ to mkedlin mkstlin mkstcol mkedlin mkedcol markconsole ; : mark-none ( -- ) \ clear the marking of any console text 0 to mkstlin 0 to mkstcol 0 to mkedcol 0 to mkedlin mkstlin mkstcol mkedlin mkedcol markconsole ; : marked? ( -- f1 ) \ return TRUE if any text is marked mkstlin mkedlin <> mkstcol mkedcol <> or ; : _do-mabort ( -- ) cr ." Aborted by Mouse!" abort ; ' _do-mabort is do-mabort : ?mouse_abort ( -- ) \ abort if both mouse buttons are down mouseflags 3 and 3 = if do-mabort then ; \ new-chain mouse-chain \ chain of things to do on mouse down mouse-chain chain-add ?mouse_abort defer auto_key ' noop is auto_key \ default to nothing defer auto_key? ' noop is auto_key? \ default to nothing : _mouse-click ( -- ) mouse-chain do-chain ; defer mouse-click ' _mouse-click is mouse-click : process-mouse ( ekey -- ) dup down_mask and \ if mouse is DOWN IF dup>r mouse_mask -1 xor and down_mask -1 xor and to mouseflags x_key? IF x_key word-split to mousey \ set y to mousex \ set x \ is mouse UP and DOWN mouseflags 3 and 1 = \ left mouse button IF r@ up_mask and \ both masks is a mousemove ?shift or IF mark-end ELSE mark-start THEN THEN mouseflags 3 and 2 = \ right mouse button IF mouse-click THEN THEN r>drop ELSE dup up_mask and \ is mouse UP IF mouse_mask -1 xor and up_mask -1 xor and to mouseflags x_key? IF x_key word-split to mousey \ set y to mousex \ set x mkstlin mkstcol mkedlin mkedcol d= \ pos NOT changed? IF mouse-click ELSE mark-end THEN THEN ELSE mouse_mask -1 xor and to mouseflags x_key? IF x_key word-split to mousey \ set y to mousex \ set x mouse-click THEN THEN THEN ; : _mkey ( -- c1 ) \ get a key from the keyboard, and handle mouse clicks auto_key BEGIN x_key dup mouse_mask and \ mouse operation IF process-mouse false THEN ?dup UNTIL ; : _mkey? ( -- c1 ) \ check for key from keyboard, and handle mouse clicks x_key? dup mouse_mask and if x_key drop \ discard waiting key process-mouse false then auto_key? ; : ?mabort ( -- ) \ give mouse a chance to recognize button press WINPAUSE ; : _mcls ( -- ) x_cls mark-none ; : _memit ( c1 -- ) \ allow mouse to abort EMIT ?mabort x_emit ; : _mtype ( a1 n1 -- ) \ allow mouse to abort TYPE ?mabort "CLIP" x_type ; : _mcol ( n1 -- ) x_col ; : _m?cr ( n1 -- ) x_?cr ; : _mcrtab ( -- ) x_crtab ; \ ------------------------------------------------------------------------------ \ ------------------------------------------------------------------------------ \ defer@ accept value defaultAccept ' accept defer@ value defaultAccept : _basic-forth-io ( -- ) \ reset to Forth IO words unhide-console sizestate 1 = \ if window is SIZE_MINIMIZED IF normal-console THEN ['] _mkey is key ['] _mkey? is key? defaultAccept is accept ['] _memit is emit ['] _mtype is type ['] _mcrtab is cr ['] _m?cr is ?cr ['] _mcls is cls ['] x_cls is page ['] x_gotoxy is gotoxy ['] x_getxy is getxy ['] x_getcolrow is getcolrow ['] _mcol is col focus-console tabing-off ; defer basic-forth-io ' _basic-forth-io is basic-forth-io forth-io-chain chain-add basic-forth-io : forth-io ( -- ) forth-io-chain do-chain ; forth-io \ set the default I/O words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ mouse typing \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : mxy>cxy ( x y -- cx cy ) \ convert from mouse xy to character xy charwh rot 2>r / 2r> swap / ; : char@screen ( x y -- c1 ) getmaxcolrow drop * + &the-screen + c@ ; : word@mouse" ( -- a1 n1 ) &the-screen mousex mousey mxy>cxy getrowoff + getmaxcolrow drop * + 2dup + c@ bl <> if 0 over ?do over i + c@ bl = if drop i leave \ found blank, leave loop then -1 +loop \ a1=screen, n1=offset to blank getmaxcolrow * swap /string \ -- a1,n1 of remaining screen bl skip \ remove leading blanks 2dup bl scan nip - \ return addr and length else + 0 then ; : word@mouse>keyboard ( -- ) \ send word at mouse to keyboard mouseflags double_mask and 0= ?exit \ double clicked mouse word@mouse" ?dup if "pushkeys bl pushkey \ push a space else drop then ; MOUSE-CHAIN CHAIN-ADD WORD@MOUSE>KEYBOARD : line@mouse" ( -- a1 n1 ) &the-screen mousex mousey mxy>cxy getrowoff + swap >r \ save x for later getmaxcolrow drop swap * + r> \ -- a1,n1 the line upto mouse -trailing ; \ remove trailing blanks : line@mouse>keyboard ( -- ) \ send the line at mouse to keyboard mouseflags 0xFF and 0x09 <> ?exit \ ctrl-left mouse button down \ along with the control key line@mouse" ?dup if "pushkeys 0x0D pushkey \ automatically press Enter else drop then ; MOUSE-CHAIN CHAIN-ADD LINE@MOUSE>KEYBOARD \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ allow the user to set the current display FONT \ doesn't work so it's deprecated \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ WINLIBRARY GDI32.DLL \ 1 proc GetDC \ 2 proc ReleaseDC \ 1 proc GetStockObject \ 2 proc SelectObject : set-font ( font_value -- ) \ conHndl call GetDC >r \ get and save the Device Control # \ call GetStockObject \ return the object information \ r@ call SelectObject drop \ selects the object \ r> conHndl call ReleaseDC drop ; DEPRECATED \ : _>bold ( -- ) \ OEM_FIXED_FONT set-font ; \ \ : _>norm ( -- ) \ ANSI_FIXED_FONT set-font ; \ \ ' _>bold is >bold \ ' _>norm is >norm \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ allow the user to hide the cursor \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Note: The Line Editor (in Lineedit.f) is using set-cursor which \ turn's on the cursor every time it's called. So a call to hide-cursor doesn't \ show any effect at all. 1 proc HideCaret : hide-cursor ( -- ) conHndl call HideCaret drop ; synonym cursor-off hide-cursor 1 proc ShowCaret : show-cursor ( -- ) conHndl call ShowCaret drop ; synonym cursor-on show-cursor \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : minimize-console ( -- ) SW_SHOWMINIMIZED conhndl call ShowWindow drop ; \ Make console the foreground window. Ignore error which will occur if we are \ running under Windows95 and we are already the foreground window. 0 proc GetActiveWindow 1 proc SetActiveWindow 1 proc SetForegroundWindow 2 proc GetWindowThreadProcessId 3 proc AttachThreadInput : (SetWindow) { hWnd proc \ hActiveThreadID hLocalThreadID -- } call GetActiveWindow dup hWnd = -if hWnd proc execute else swap call GetWindowThreadProcessId to hActiveThreadID 0 hWnd call GetWindowThreadProcessId to hLocalThreadID 1 hLocalThreadID hActiveThreadID Call AttachThreadInput hWnd proc execute 0 hLocalThreadID hActiveThreadID Call AttachThreadInput then 3drop ; : SetForegroundWindow call SetForegroundWindow ; \ temp : SetActiveWindow call SetActiveWindow ; \ temp : (SetForegroundWindow) ( hwnd -- ) \ w32f \ *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. ['] SetForegroundWindow (SetWindow) ; : (SetActiveWindow) ( hWnd -- ) \ *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. ['] SetActiveWindow (SetWindow) ; : _foreground-console ( -- ) conhndl (SetForegroundWindow) ; : _activate-console ( -- ) conhndl (SetActiveWindow) ; defer foreground-console ( -- ) ' _foreground-console is foreground-console defer activate-console ( -- ) ' _activate-console is activate-console \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ fill in some deferred words default functions \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ' x_gotoxy is-default gotoxy ' x_getxy is-default getxy ' x_getcolrow is-default getcolrow --- NEW FILE: CONSOLE.F --- \ $Id: CONSOLE.F,v 1.1 2006/09/23 10:18:34 dbu_de Exp $ \ File: Console.f \ Author: Dirk Busch \ Created: November 9th, 2003 - 10:32 dbu \ Updated: January 14th, 2004 - 13:09 dbu \ \ Win32Forth Terminal I/O (Moved here from Primutil.f ) cr .( Loading... Console I/O Part 1) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ get console window handle \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ defer conHndl ' _conHndl is conHndl \ so we can change it later \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Keyboard Mask Constant, MUST MATCH THOSE IN TERM.H !! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 65536 ( 0x10000 ) constant function_mask \ function key maks 131072 ( 0x20000 ) constant special_mask \ special keyboard key mask 262144 ( 0x40000 ) constant control_mask \ control key mask 524288 ( 0x80000 ) constant shift_mask \ shift key mask 1048576 ( 0x100000 ) constant alt_mask \ alt key mask 2097152 ( 0x200000 ) constant mouse_mask \ mouse operations 4194304 ( 0x400000 ) constant menu_mask \ menu operations 8192 ( 0x002000 ) constant proc_mask \ procedure base mask 16777216 ( 0x1000000 ) constant double_mask \ double click mask 33554432 ( 0x2000000 ) constant down_mask \ mouse down mask 67108864 ( 0x4000000 ) constant up_mask \ mouse up mask \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ sound stuff \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ VARIABLE TONE_FREQ 700 TONE_FREQ ! VARIABLE TONE_DURA 50 TONE_DURA ! 2 PROC Beep : TONE ( frequency duration-ms -- ) swap call Beep drop ; : BEEP! ( frequency duration-ms -- ) TONE_DURA ! TONE_FREQ ! ; : _BEEP ( -- ) tone_freq @ tone_dura @ tone ; defer beep ' _beep is beep \ default sound stuff synonym NOTE tone DEPRECATED \ use TONE instad \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ define some deferred words with their functions, and defaults \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ defer page ' cls is page \ the next two words are deprecated because changeing the \ console font doesn't realy work defer >bold DEPRECATED \ ' noop is >bold \ set bold font in console window defer >norm DEPRECATED \ ' noop is >norm \ set normal font in console window \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Some words that improve compatibility with existing F-PC code. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ synonym SP>COL COL DEPRECATED synonym AT-XY gotoxy \ ANS Version of gotoxy : cols ( -- n1 ) \ current screen columns getcolrow drop ; : rows ( -- n1 ) \ current screen rows getcolrow nip ; 0 value accept-cnt \ current count of chars accepted : _faccept ( a1 n1 -- n2 ) 0 swap 0 ?do drop i to accept-cnt \ save in case we need it key case 8 of i 1 < \ if input is empty if 0 \ do nothing but beep \ beep at user else 1- \ decrement address 1 -1 08 emit bl emit 08 emit then endof 27 of dup c@ emit 1+ 1 endof 13 of i leave endof dup emit 2dup swap c! \ place the character swap 1+ swap \ bump the address 1 swap \ loop increment endcase i 1+ swap \ incase loop completes +loop nip ; ' _faccept is accept \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Words that position on the screen \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 8 value tab-size 8 value left-margin 4 value right-margin 0 value tab-margin 5 value tabs-max 0 value tabing? \ are we tabing, default to no 0 value first-line? \ is this the first line of a paragraph -8 value indent \ indent/outdent spaces : wrap? ( n1 -- f1 ) \ return true if column n1 crosses into the \ right margin area getcolrow drop right-margin - > ; : tab-wrap? ( n1 -- f1 ) \ return true if column exceeds the maximum \ desired tabs, or crosses into the right \ margin area dup tabs-max tab-size * > swap wrap? or ; : TAB ( -- ) getxy drop tab-size / 1+ tab-size * col ; : 0TAB ( -- ) \ left margin goes to left edge of screen 0 to tab-margin ; : +TAB ( --- ) tab-size +to tab-margin tab-margin tab-wrap? IF 0tab THEN ; : -TAB ( --- ) tab-margin tab-size - 0 MAX DUP to tab-margin tab-size < IF tabs-max tab-size * to tab-margin THEN ; : FIRST-LINE ( -- ) \ set first line flag true to first-line? 0tab ; : TABING-ON ( -- ) true to tabing? ; : TABING-OFF ( -- ) false to tabing? ; synonym tabbing-off tabing-off synonym tabbing-on tabing-on : x_CRTAB ( -- ) x_cr \ fixed stack overflow bug November 15th, 2003 - 13:26 dbu tabing? 0= ?exit first-line? if left-margin indent + spaces false to first-line? else left-margin spaces tab-margin spaces then ; DEFER CRTAB ' x_CRTAB IS CRTAB : ?LINE ( n1 -- ) 0 max getxy drop + wrap? if cr then ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Additional words for the console \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ WINLIBRARY W32FCONSOLE.DLL LIBRARY W32FCONSOLE.DLL 1 PROC k_fpushkey 2 PROC c_setfgbg 0 PROC c_getfg 0 PROC c_getbg 0 PROC c_thescreen 0 PROC c_charwh 2 PROC c_setcharwh 2 PROC c_resize 1 PROC c_setcursorheight 0 PROC c_getcursorheight 1 PROC c_wscroll 0 PROC c_rowoffset 0 PROC c_maxcolrow 2 PROC c_setmaxcolrow 1 PROC c_setfont : x_pushkey ( c1 -- ) \ push c1 into the keyboard input stream Call k_fpushkey drop ; : x_"pushkeys ( a1 n1 -- ) \ push the characters of string a1,n1 0max 127 min bounds ?do i c@ x_pushkey loop ; 1 PROC GetKeyState : x_shiftmask ( -- mask ) 0 17 ( VK_CONTROL ) Call GetKeyState 32768 and \ if control is down if control_mask or then \ then include control bit 16 ( VK_SHIFT ) Call GetKeyState 32768 and \ if shift is down if shift_mask or then ; \ then include shift bit : ?shift ( -- f1 ) \ return true if shift is down shiftmask shift_mask and 0<> ; : ?control ( -- f1 ) \ return true if control is down shiftmask control_mask and 0<> ; : x_cursorinview ( -- ) \ make sure cursor is visible in the window ; : x_fgbg! ( forground background -- ) Call c_setfgbg drop ; : x_fg@ ( -- foreground ) Call c_getfg ; : x_bg@ ( -- background ) Call c_getbg ; : x_&the-screen ( -- a1 ) \ get the forth relative address of the users \ console screen memory buffer Call c_thescreen ; : x_charWH ( -- width height ) \ get the width and height of the \ current console font Call c_charwh word-split swap ; 3 PROC InvalidateRect : ConsoleRepaint ( -- ) \ redraw console window 1 0 _conHndl call InvalidateRect drop ; : x_SetcharWH ( width height -- ) \ set the width and height of the Call c_setcharwh drop \ current console font ConsoleRepaint ; \ force repaint : x_setcolrow ( cols rows -- ) \ set the console size Call c_resize drop ; : SetConsoleFont ( hFont -- ) \ set the console font. If hFont is NULL the \ default font will be set. call c_setfont drop ConsoleRepaint ; \ force repaint \ Usage of SetConsoleFont: \ \ Font cFont \ 16 Height: cFont \ 8 Width: cFont \ s" Courier New" SetFaceName: cFont \ FW_NORMAL Weight: cFont \ Create: cFont \ Handle: cFont SetConsoleFont \ zHandle: cFont \ don't let Win32Forth destroy the font; the console does it !!! synonym set-consize setcolrow 4 PROC SetWindowPos : set-conpos ( x y -- ) \ set the console position 2>r ( SWP_NOSIZE ) 1 0 0 2r> ( HWND_TOP ) 0 _conHndl call SetWindowPos drop ; 1 PROC SetCursor 2 PROC LoadCursor : set-pointer ( pointer-identifier -- ) \ set the pointer shape 0 call LoadCursor call SetCursor drop ; : x_set-cursor ( cursor-height -- ) \ set the cursor height Call c_setcursorheight drop ; : x_get-cursor ( -- cursor-height ) \ get the cursor height Call c_getcursorheight ; \ Note: The cursor hight is used by the Line Editor (in Lineedit.f) to \ show the current insert/overstrike mode. So a direct call to \ set-cursor, big-cursor or norm-cursor doesn't show any efect at all. : big-cursor ( -- ) \ set a block cursor charWH nip set-cursor ; 2 value norm-height \ hold the norm cursor height : norm-cursor ( -- ) \ set a normal cursor norm-height set-cursor ; 0 value havemenu? : havemenu! ( flag -- ) to havemenu? ; 1 PROC GetDC : conDC ( -- dc ) \ get the console device context _conHndl call GetDC ; 0 value saveconx 0 value savecony 2 PROC ShowWindow : show-window ( n -- ) _conHndl call ShowWindow drop ; : hide-console ( -- ) saveconx ?exit getcolrow to savecony to saveconx ( SW_HIDE ) 0 show-window ; : unhide-console ( -- ) saveconx 0= ?exit ( SW_SHOW ) 5 show-window saveconx savecony setcolrow \ resize to original size 0 to saveconx 0 to savecony ; synonym show-console unhide-console : normal-console ( -- ) \ un-minimizes a minimized console window ( SW_NORMAL ) 1 show-window ; 1 PROC SetFocus : focus-console ( -- ) _conHndl call SetFocus drop ; : x_setrowoff ( n1 -- ) \ set the console row offset Call c_wscroll drop ; : x_getrowoff ( -- n1 ) \ get the current console row offset Call c_rowoffset ; : x_getmaxcolrow ( -- maxcols maxrows ) \ get maximum window columns Call c_maxcolrow word-split ; : x_setmaxcolrow ( maxcols maxrows -- ) \ set the saved screen area and clear 16384 min 20 max swap \ clip rows 256 min 26 max \ clip columns Call c_setmaxcolrow drop ; ' X_CURSORINVIEW IS CURSORINVIEW ' X_FGBG! IS FGBG! ' X_FG@ IS FG@ ' X_BG@ IS BG@ ' X_PUSHKEY IS PUSHKEY ' X_"PUSHKEYS IS "PUSHKEYS ' X_&THE-SCREEN IS &THE-SCREEN ' X_CHARWH IS CHARWH ' X_SETCHARWH IS SETCHARWH ' X_SHIFTMASK IS SHIFTMASK ' X_SETCOLROW IS SETCOLROW ' X_SET-CURSOR IS SET-CURSOR ' X_GET-CURSOR IS GET-CURSOR ' X_SETROWOFF IS SETROWOFF ' X_GETROWOFF IS GETROWOFF ' X_GETMAXCOLROW IS GETMAXCOLROW ' X_SETMAXCOLROW IS SETMAXCOLROW \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Facility extension words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ SYNONYM EKEY KEY ( -- u ) SYNONYM EKEY? KEY? ( -- flag ) : ekey>char ( u -- u false | char true ) \ returns TRUE if displayable character dup 0 255 between ; TRUE constant emit? ( -- flag ) \ return TRUE if its ok to emit a character \s \ arm removed 17/05/2005 23:36:13 \ All internal console I/O words have an x_ prefix now. \ The following words are deprecated. \ They are added for compatiblity to existing code only. SYNONYM _INIT-CONSOLE x_INIT-CONSOLE DEPRECATED SYNONYM _INIT-SCREEN x_INIT-SCREEN DEPRECATED SYNONYM _ACCEPT x_ACCEPT DEPRECATED SYNONYM _TYPE x_TYPE DEPRECATED SYNONYM _EMIT x_EMIT DEPRECATED SYNONYM _CR x_CR DEPRECATED SYNONYM _CLS x_CLS DEPRECATED SYNONYM _?CR x_?CR DEPRECATED SYNONYM _SIZESTATE x_SIZESTATE DEPRECATED SYNONYM _GOTOXY x_GOTOXY DEPRECATED SYNONYM _GETXY x_GETXY DEPRECATED SYNONYM _GETCOLROW x_GETCOLROW DEPRECATED SYNONYM _MARKCONSOLE x_MARKCONSOLE DEPRECATED SYNONYM _BYE k_BYE DEPRECATED --- NEW FILE: LINEEDIT.F --- \ $Id: LINEEDIT.F,v 1.1 2006/09/23 10:18:34 dbu_de Exp $ \ LEDIT.SEQ Line Editor Utility by Tom Zimmer cr .( Loading Line Editor...) \ 07-18-95 SMuB replaced getxy and gotoxy calls with _legetxy, _legotoxy. \ These routines use buffer coordinates instead of screen coordinates \ since screen coordinates are volatile. (( Here is a relatively simple editor for editing one line strings. Support is provided for strings up to 255 characters in length, with full word and character operations using keypad or WordStar keys as follows: Ctrl-A Left word Ctrl-S Left character Ctrl-D Right character Ctrl-F Right word Ctrl-G Forward delete Ctrl-T Word delete Ctrl-Y Line delete or clear Left arrow Left character Ctrl-Left arrow Left word Right arrow Right character Ctrl-Right arrow Right word Home Beginning of line End End of line ESC Discard changes and leave Return/Enter Save changes and leave The parameters needed by LINEEDIT are as follows: lineeditor ( x y a1 n1 --- ) x = char pos on row, zero = left edge y = row number, zero = top line a1 = counted string n1 = edit limit length, maximum value = 80 Here is an example of a command that would edit a line of text in SAMPLEBUFFER, with a maximum length of 12 characters, at location row 10 column 5 on the screen. 5 10 samplebuffer 12 lineedit Two auto resetting flags can be used to control the behavior of the line editor in special ways. The STRIPING_BL'S boolean "VALUE" determines whether the line editor will strip trailing blanks from an edited string at the completion of the edit. this VALUE defaults to TRUE, do strip trailing blanks. false to STRIPPING_BL'S will prevent line edit from stripping spaces. The AUTOCLEAR boolean "VALUE" determines whether the line edit buffer will be automatically cleared if the first character you enter on starting an edit is a normal text char. This is used to ease the users life in the situation where you want to give them the option of re-using a string or easily entering a new one without having to delete the old string first. This VALUE defaults to FALSE, no autoclear. true to AUTOCLEAR will cause line edit to automatically clear the edit string if a letter if the first thing entered. )) \ only forth also definitions anew -lineedit.f in-application INTERNAL \ internal words start here EXTERNAL true value stripping_bl's \ are we stripping trailing blanks? false value autoclear \ automatically clear line if first true value insertmode \ insert/overwrite mode flag INTERNAL \ internal words start here variable saveflg \ are we saving the results 0 value ?ldone \ is line edit done? 0 value lchar \ recent line edit character 0 value ledit-x \ where we are editing X 0 value ledit-y \ where we are editing Y 0 value lenlimit \ line edit length limit defer ledbutton ' noop is ledbutton MAXCOUNTED constant maxedit create editbuf MAXSTRING allot \ our edit buffer, editbuf off \ 255 characters max 0 value editpos \ current edit position in buffer : _legetxy ( --- x ~y ) \ Negative y indicates buffer coordinates getxy getrowoff + invert ; : _legotoxy ( x y --- ) \ Goto screen or buffer coordinates dup 0< if \ if y is negative, go to buffer coordinates (x,~y) invert dup getrowoff dup rows + 1- between 0= if \ If the desired buffer y is not in the window, scroll it in dup rows - 1+ setrowoff then getrowoff - then gotoxy ; : lcalcx ( -- x ) \ calculate cursor x positon editpos COLS /mod drop ledit-x + ; : lcalcy ( -- y ) \ calculate cursor y positon editpos COLS / ledit-y - getrowoff 0= if 1- then ; \ rewritten for better line wraping \ Sonntag, Januar 16 2005 dbu : .lecursor ( --- ) \ show the cursor \+ accept-cnt editpos to accept-cnt lcalcx lcalcy _legotoxy ; : .leline ( --- ) \ redisplay edit line ledit-x ledit-y _legotoxy editbuf count type lenlimit ledit-x + COLS 1- min COL ; : __le-ldel ( -- ) \ Line delete 0 editbuf c! 0 to editpos ; : _lichar ( c1 -- ) autoclear \ should we clear the line on the if __le-ldel \ first character typed? false to autoclear then insertmode if editbuf 1+ editpos + dup 1+ maxedit editpos - move editbuf c@ 1+ lenlimit min editbuf c! then editbuf 1+ editpos + c! \ removed 'COLS 1- min' for better line wraping \ Sonntag, Januar 16 2005 dbu editpos 1+ lenlimit min ( COLS 1- min ) to editpos editpos editbuf c@ max editbuf c! ; : ?lechar ( --- ) \ handle normal keys, insert them lchar bl 0xFF between if lchar _lichar then ; : _le-home ( --- ) \ beginning of line 0 to editpos ; : _le-end ( --- ) \ End of line editbuf c@ to editpos ; : _le-right ( --- ) \ right a character \ removed 'COLS 1- min' for better line wraping \ Sonntag, Januar 16 2005 dbu editpos 1+ editbuf c@ min ( COLS 1- min ) to editpos ; : _le-left ( --- ) \ left a character editpos 1- 0MAX to editpos ; : _ledone ( --- ) \ flag edit is finished, save changes true to ?ldone saveflg on ; : _lequit ( false --- true ) \ flag edit is finished, discard chngs true to ?ldone \+ mark-none mark-none saveflg off ; defer _le-ret ' _ledone is _le-ret defer _le-tab ' _ledone is _le-tab defer _le-quit ' _lequit is _le-quit defer _le-LF ' noop is _le-LF defer _le-pgup ' noop is _le-pgup defer _le-pgdn ' noop is _le-pgdn defer _le-up ' noop is _le-up defer _le-down ' noop is _le-down defer _le-ldel ' __le-ldel is _le-ldel : _le-fdel ( --- ) \ Forward delete editpos 1+ editbuf c@ max editbuf c! editbuf 1+ editpos + dup 1+ swap maxedit editpos - move -1 editbuf c+! ; : >to=bl ( --- ) \ forward to a blank editbuf 1+ dup maxedit + swap editpos + ?do i c@ bl = ?leave 1 +to editpos loop editbuf c@ editpos min to editpos ; : >to<>bl ( --- ) \ forward to a non blank editbuf 1+ dup maxedit + swap editpos + ?do i c@ bl <> ?leave 1 +to editpos loop editbuf c@ editpos min to editpos ; : _le-rword ( --- ) \ Forward to next word >to=bl >to<>bl ; : <to=bl+1 ( --- ) \ back to char following BL editpos 1- 0MAX to editpos editbuf 1+ dup editpos + 1- editbuf 1+ max ?do i c@ bl = ?leave -1 +to editpos -1 +loop ; : <to<>bl ( --- ) \ Back to non blank editpos 1- 0MAX to editpos editbuf 1+ dup editpos + 1- editbuf 1+ max ?do i c@ bl <> ?leave -1 +to editpos loop ; : _le-lword ( --- ) \ back a word <to<>bl <to=bl+1 ; : _le-bdel ( --- ) \ back delete editpos editbuf c@ max editbuf c! editpos ( --- f1 ) _le-left ( --- f1 ) if insertmode \ if we are in insertmode if _le-fdel \ then delete the character else bl editbuf 1+ editpos + c! \ else change char to blank then else beep then ; : _le-wdel ( --- ) \ word delete begin editpos editbuf c@ < editbuf 1+ editpos + c@ bl <> and while _le-fdel repeat begin editpos editbuf c@ < editbuf 1+ editpos + c@ bl = and while _le-fdel repeat ; : strip_bl's ( --- ) \ strip blanks from editbuf editpos >r _le-end begin _le-left editbuf 1+ editpos + c@ bl = editpos 0<> and while _le-fdel repeat editbuf c@ r> min 0MAX to editpos editbuf c@ 1 = \ count=1 & char=blank editbuf 1+ c@ bl = and if 0 editbuf c! \ then reset buffer to empty then ; : _le-ins ( --- ) \ toggle insert mode insertmode 0= dup to insertmode if big-cursor else norm-cursor then ; : _le-any ( --- ) \ handle any character entry ; create control-tab ' noop , ' _le-lword , ' noop , ' _le-pgdn , ' _le-right , ' _le-up , ' _le-rword , ' _le-fdel , ' _le-bdel , ' _le-tab , ' _le-LF , ' noop , ' noop , ' _le-ret , ' noop , ' noop , ' noop , ' noop , ' _le-pgup , ' _le-left , ' _le-wdel , ' noop , ' _le-ins , ' noop , ' _le-down , ' _le-ldel , ' noop , ' _le-quit , ' noop , ' noop , ' noop , ' noop , : ?control ( --- ) \ handle control characters lchar bl < if false to autoclear \ no auto clear now \ temp changed: because EXEC: must be ported first (( lchar exec: \ 0 null 1 a 2 b 3 c 4 d 5 e 6 f noop _le-lword noop _le-pgdn _le-right _le-up _le-rword \ 7 g 8 h 9 i LF 11 k 12 l Enter _le-fdel _le-bdel _le-tab _le-LF noop noop _le-ret \ 14 n 15 o 16 p 17 q 18 r 19 s 20 t noop noop noop noop _le-pgup _le-left _le-wdel \ 21 u 22 v 23 w 24 x 25 y 26 z Esc noop _le-ins noop _le-down _le-ldel noop _le-quit \ 28 \ 29 ] 30 ^ 31 _ noop noop noop noop )) lchar cells control-tab + @ execute then ; : ?func ( --- ) \ handle function keys \ if function key bit is set lchar function_mask special_mask or and \ func or special lchar shift_mask and shift_mask = or \ or Shift mask lchar bl < or \ or control key if \ or other keypad key false to autoclear \ no auto clear now \ "ledit-chain" allows addingto or over-riding a function ckey at Forth commandline \ use CHAIN-ADD to add a function test, and CHAIN-ADD-BEFORE to over-ride an \ existing functionkey during commandline editing. lchar FALSE ledit-chain do-chain 0= if case k_home of _le-home endof \ Home k_up of _le-up endof \ Up arrow k_pgup of _le-PgUp endof \ PgDn k_left of _le-left endof \ Left arrow k_right of _le-right endof \ Right arrow k_end of _le-end endof \ End k_down of _le-down endof \ Down arrow k_pgdn of _le-PgDn endof \ PgDn k_insert of _le-ins endof \ Ins k_delete of _le-fdel endof \ Del k_left +k_control of _le-lword endof \ Ctrl Left arrow k_right +k_control of _le-rword endof \ Ctrl Right arrow endcase else drop \ already handled, discard key value 0 to lchar then then ; \ c1 = keyboard character \ f1 = true for done editing : _le-key ( c1 --- ) \ process a key to lchar ?lechar \ handle normal ascii ?func \ function characters ?control ; \ control chars \ x = char pos on row \ y = line number \ a1 = counted string \ n1 = edit limit length : <ledit> ( x y a1 n1 --- ) \ Edit line currently in EDITBUF. lenlimit >r get-cursor >r over c@ editpos min to editpos maxedit min to lenlimit \ save max edit length dup >r \ save source address editbuf over c@ lenlimit min 1+ move editbuf c@ lenlimit min editbuf c! dup 0< 0= \ SMuB if getrowoff + invert \ SMuB then \ SMuB to ledit-y to ledit-x \ save origin false to insertmode _le-ins _le-ins false to ?ldone begin .leline .lecursor key _le-key ?ldone until saveflg @ dup \ proper save exit if stripping_bl's \ do we want to strip blanks? if strip_bl's then true to stripping_bl's \ force it next time editbuf r@ over c@ lenlimit min 1+ move then r>drop r> set-cursor ( --- f1 ) r> to lenlimit false to autoclear ; \ no automatic line clear EXTERNAL \ externally available words start here \ x = char pos on row \ y = line number \ a1 = counted string \ n1 = edit limit length \ f1 = true for saved changes \ f1 = false for canceled with ESC : lineeditor ( x y a1 n1 --- f1 ) \ Edit line in a1 \ defer@ _le-quit >r ['] _lequit is _le-quit \ defer@ _le-LF >r ['] noop is _le-LF ['] _le-quit defer@ >r ['] _lequit is _le-quit ['] _le-LF defer@ >r ['] noop is _le-LF 0 to editpos <ledit> r> is _le-LF r> is _le-quit ; \ TEST TEST TEST \ create buf 200 allot \ 0 10 buf 100 lineeditor drop \ buf count type INTERNAL \ --------------------------------------------------------------------------- \ Line editor version of ACCEPT \ --------------------------------------------------------------------------- MAXSTRING constant b/accept \ each commandline is MAXSTRING bytes 31 constant n/accept \ save 31 previous command lines \ use 31 to make it fit in 8k bytes 0 value accept# 0 value accepted? \ temp changed: because POINTER.F must be ported first \ b/accept n/accept * Pointer prev-accept-buf create prev-accept-buf b/accept n/accept * allot : accept-init ( -- ) 0 to accept# prev-accept-buf b/accept n/accept * erase ; initialization-chain chain-add accept-init \ add to init chain accept-init create laccept-buf b/accept allot laccept-buf off : +accept# ( n1 -- ) accept# + n/accept mod to accept# ; : prev-accept-buf" ( -- a1 n1 ) \ Get the current line from the line editor buffer. prev-accept-buf accept# b/accept * + count ; : accept-lup? ( -- f ) \ Returns true if it's ok to move one line up in the line editor buffer. accept# 0> ; : accept-lup ( -- ) \ Move one line up in the line editor buffer. accept-lup? if false to accepted? -1 +accept# prev-accept-buf" editbuf place editbuf c@ to editpos else beep then ; : accept-ldown? ( -- f ) \ Returns true if it's ok to move one line down in the line editor buffer. 1 +accept# prev-accept-buf" nip 0> -1 +accept# ; : accept-ldown ( -- ) \ Move one line down in the line editor buffer. accept-ldown? if accepted? 0= if 1 +accept# then false to accepted? prev-accept-buf" editbuf place editbuf c@ to editpos else beep then ; : __laccept ( a1 n1 -- n2 ) \+ ED_READY 0 ED_READY editor-message \ notify editor we are ready ['] accept-lup is _le-up ['] accept-ldown is _le-down laccept-buf c@ \ backup current line if laccept-buf count prev-accept-buf accept# b/accept * + place 1 +accept# then true to accepted? swap >r >r _legetxy laccept-buf dup off r> lineeditor if laccept-buf count r@ swap move laccept-buf c@ _legetxy nip _legotoxy else editbuf off _legetxy nip 0 swap 2dup _legotoxy cols 1- COL _legotoxy 1 +accept# then r>drop laccept-buf c@ ; : _laccept ( a1 n1 -- n2 ) \ line editor version of ACCEPT \ defer@ _le-up >r \ defer@ _le-down >r ['] _le-up defer@ >r ['] _le-down defer@ >r ['] __laccept catch \ -- f1 r> is _le-down \ restore these functions r> is _le-up ( -- f1 ) throw ; ' _laccept is accept ' _laccept to defaultAccept \ make this the default handler MODULE \s variable samplebuffer 128 allot : sample ( --- ) s" Zimmer, Harold" samplebuffer place true to autoclear 10 04 samplebuffer 24 lineeditor drop cr samplebuffer count type ; --- NEW FILE: KEYBOARD.F --- \ $Id: KEYBOARD.F,v 1.1 2006/09/23 10:18:34 dbu_de Exp $ \ KEYBOARD.F functon key constants by Tom Zimmer cr .( Loading Function Key Words...) in-system ' CONSTANT alias LITKEY in-application 0x1B litkey K_ESC 0x09 litkey K_TAB 0x08 litkey K_BACKSPACE 0x0D litkey K_CR 0x0A litkey K_LF in-system : fkey ( n1 -<name>- ) function_mask or constant ; in-application 0x01 fkey K_F1 0x02 fkey K_F2 0x03 fkey K_F3 0x04 fkey K_F4 0x05 fkey K_F5 0x06 fkey K_F6 0x07 fkey K_F7 0x08 fkey K_F8 0x09 fkey K_F9 0x10 fkey K_F10 0x11 fkey K_F11 0x12 fkey K_F12 in-system : splkey ( n2 -<name>- ) special_mask or constant ; in-application 0x00 splkey K_HOME 0x01 splkey K_END 0x02 splkey K_INSERT 0x03 splkey K_DELETE 0x04 splkey K_LEFT 0x05 splkey K_RIGHT 0x06 splkey K_UP 0x07 splkey K_DOWN 0x08 splkey K_SCROLL 0x09 splkey K_PAUSE 0x10 splkey K_PGUP 0x11 splkey K_PGDN : +K_SHIFT ( c1 -- c2 ) shift_mask or ; \ add in shift bit \ 07/18/95 08:56 tjz ALT keys are for Windows Use ONLY!" : +K_ALT ( c1 -- c2 ) alt_mask or ; \ add in the Alt bit : +K_CONTROL ( c1 -- c2 ) dup proc_mask 0x7FF or and upc 'A' 'Z' between if 0xFF1F and \ handle control letters else control_mask or \ add in control bit then ; \S The above words are used as shown in the following example: : key_test ( -- ) begin cr ." Press a key, Enter to stop: " key case k_f1 of ." F1" endof k_f2 of ." F2" endof k_f3 of ." F3" endof k_f4 of ." F4" endof k_f5 of ." F5" endof k_f6 of ." F6" endof k_f7 of ." F7" endof k_f8 of ." F8" endof k_f9 of ." F9" endof k_f10 of ." F10" endof k_f11 of ." F11" endof k_f12 of ." F12" endof k_f1 +k_control of ." Control F1" endof k_f2 +k_control of ." Control F1" endof k_f3 +k_control of ." Control F1" endof k_f4 +k_control of ." Control F1" endof k_f5 +k_control of ." Control F1" endof k_f6 +k_control of ." Control F1" endof k_f7 +k_control of ." Control F1" endof k_f8 +k_control of ." Control F1" endof k_f9 +k_control of ." Control F1" endof k_f10 +k_control of ." Control F10" endof k_f11 +k_control of ." Control F11" endof k_f12 +k_control of ." Control F12" endof k_f1 +k_shift of ." Shift F1" endof k_f2 +k_shift of ." Shift F1" endof k_f3 +k_shift of ." Shift F1" endof k_f4 +k_shift of ." Shift F1" endof k_f5 +k_shift of ." Shift F1" endof k_f6 +k_shift of ." Shift F1" endof k_f7 +k_shift of ." Shift F1" endof k_f8 +k_shift of ." Shift F1" endof k_f9 +k_shift of ." Shift F1" endof k_f10 +k_shift of ." Shift F10" endof k_f11 +k_shift of ." Shift F11" endof k_f12 +k_shift of ." Shift F12" endof 0x0D of ." Stopping" exit endof dup h. ." Unknown key" endcase ." pressed." again ; |
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X