Re: simple line drawing

Hi Charley,
I am not familiar with Canvas and Objects etc; but listed below ( hope not
too big) are 2 early trial files of mine. Winxl is modified from win2.f,
with an extra menu item, sketch, which here is a preset draw. This calls
for including skxl.txt, which was modified from Scribble. DRAW makes a
drawing window in the client area of the main APP-WINDOW, and runs the
draw commands every time the window is repainted, via WM_PAINT.
 Possibly some code may not be quite proper, but you can run this.

\ winxl.f:
\ derived from win2.f
\ OPTIONAL WIN2 A stand-alone windows application template including a simple menu.
\ retrieve winxl.txt

ONLY FORTH ALSO DEFINITIONS DECIMAL

0 VALUE hAPP
0 VALUE APPLICATION

include skxl.txt

\ menu ----------------------------------------

100 ENUM M_EXIT
    ENUM M_ABOUT
    enum M_sketch
DROP

MENU APP-MENU

   POPUP "&File"
      M_sketch menuitem "&Sketch"
      M_EXIT MENUITEM "E&xit"

   END-POPUP

   POPUP "&Help"
      M_ABOUT MENUITEM "&About"
   END-POPUP

END-MENU

{ -- Command message execution -- }

: APP-ABOUT ( -- res )
   HWND Z" sketcher"
   Z" About" MB_OK MessageBox DROP 0 ;

: APP-EXIT ( -- res )
   HWND WM_CLOSE 0 0 PostMessage DROP 0 ;

: app-sk draw 0 ;

[SWITCH APP-COMMANDS ZERO ( cmd -- res )
   M_EXIT RUNS APP-EXIT
   M_ABOUT RUNS APP-ABOUT
   M_sketch runs app-sk
SWITCH]

\ Window creation and message dispatcher.

CREATE APP-CLASS ,Z" AppName"
CREATE APP-TITLE ,Z" Trial Shell"

: APP-DESTROY ( -- res ) 0 TO hAPP
   APPLICATION IF 0 PostQuitMessage DROP THEN 0 ;

: APP-CREATE ( -- res )
   HWND APP-MENU LoadMenuIndirect SetMenu DROP 0 ;

: APP-CLOSE ( -- res )
   HWND GetMenu DestroyMenu DROP HWND DestroyWindow DROP 0 ;

[SWITCH APP-MESSAGES DEFWINPROC ( msg -- res )
   WM_DESTROY RUNS APP-DESTROY
   WM_CREATE RUNS APP-CREATE
   WM_CLOSE RUNS APP-CLOSE
   WM_COMMAND RUN: WPARAM LOWORD APP-COMMANDS ;
   WM_LBUTTONDOWN RUNS APP-ABOUT
SWITCH]

:NONAME MSG LOWORD APP-MESSAGES ; 4 CB: APP-WNDPROC

: /APP-CLASS ( -- )
      0 CS_OWNDC OR
         CS_HREDRAW OR
         CS_VREDRAW OR \ class style
      APP-WNDPROC \ wndproc
      0 \ class extra
      0 \ window extra
      HINST \ hinstance
      0 \
      NULL IDC_ARROW LoadCursor \
      WHITE_BRUSH GetStockObject \
      0 \ no menu
      APP-CLASS \ class name
   DefineClass DROP ;

: /APP-WINDOW ( cmdshow -- hwnd ) >R
      0 \ extended style
      APP-CLASS \ window class name
      APP-TITLE \ window caption
      WS_OVERLAPPEDWINDOW \ window style
      20 20 800 600 \ position and size
      0 \ parent window handle
      0 \ window menu handle
      HINST \ program instance handle
      0 \ creation parameter
   CreateWindowEx ?DUP IF
      DUP TO hAPP
      DUP R> ShowWindow DROP
      DUP UpdateWindow DROP
   ELSE
      R> DROP
   THEN ;

:PRUNE ?PRUNE -EXIT
   hAPP IF hAPP WM_CLOSE 0 0 SendMessage DROP THEN
   APP-CLASS HINST UnregisterClass DROP ;

: DOSK ( -- )
   /APP-CLASS SW_SHOWNORMAL /APP-WINDOW DROP ;

: WINMAIN ( -- )
   1 TO APPLICATION DOSK DISPATCHER
   'ONSYSEXIT CALLS
   0 ExitProcess ;

 dosk

\\ Below for turnkey

 -1 THRESHOLD
 ' WINMAIN 'MAIN !
  PROGRAM Winxl
bye
\ end winxl.f

\ ----------------------------------------
\ skxl.txt:
\ skxl.txt:
\ derived from SCRIBBLE

0 VALUE hwndrw
0 value hpen0 0 value hpen2
3 import: CreatePen
 : crpens ( -- )
          0 0 0 CreatePen to hpen0
          2 0 0 CreatePen to hpen2 ;

9 import: Arc
8 value ns \ no. of draw segments in later version

: cir0 ( hdc -- )
       70 90 90 70 66 66 66 66 arc drop ;

: DOPAINT ( -- res )
  ns 0 > IF
          64 R-ALLOC
          HWND OVER BeginPaint LOCALS| hdc ps |
\ setim \ set isotropic mode and extents
          hdc hpen0 SelectObject drop
           hdc 80 80 0 MoveToEx drop
           hdc 400 80 LineTo drop
           hdc 400 280 LineTo drop
          hdc hpen2 SelectObject drop
           hdc 80 280 LineTo drop
           hdc 80 80 LineTo drop
          hdc hpen0 SelectObject drop
          hdc cir0

\ ns 0 do hdc i segdrw
\ loop
          HWND ps EndPaint drop
         ELSE HWND MSG WPARAM LPARAM DefWindowProc drop
         THEN 0 ;

: DOPRESS ( -- res ) ;

: DOREPAINT ( -- res )
   HWND 0 1 InvalidateRect DROP 0 ;

: DEFMSG ( n -- res )
   DROP HWND MSG WPARAM LPARAM DefWindowProc ;

[SWITCH drw-MESSAGES DEFMSG
   WM_CREATE RUN: crpens 0 ;
   WM_CLOSE RUN: 0 TO hwndrw HWND DestroyWindow DROP 0 ;
   WM_PAINT RUNS DOPAINT
   WM_SIZE RUN: ( dwSIZE) DOREPAINT ;
SWITCH]

: Sk-PROC
   MSG $FFFF AND drw-MESSAGES ;

' Sk-PROC 4 CB: drwproc

: SubName ( -- zstr ) Z" Draw" ;
: SubTitle ( -- zstr ) Z" SHAPE DIAGRAM " ;

: cwsiz ( -- 0 0 cx cy )
       0 0
       hwnd pad getclientrect drop
       pad 8 + w@ pad 12 + w@ \ 0 0 cx cy
;

: CreatDrWin ( -- f )
   0 \ exended style
\ WS_EX_CLIENTEDGE OR
   SubName \ class name
   SubTitle \ window title
   0
\ WS_OVERLAPPEDWINDOW or
   WS_VISIBLE OR
   WS_CHILD OR
   cwsiz \ x y cx cy
   hAPP \ parent window
   0 \ menu
   HINST \ instance handle
   0 \ creation parameters
   CreateWindowEx
;

{ DrawClass was used in place of DefaultClass below to get a different bkgnd colour:
: DrawClass ( zname callback -- hclass ) SWAP >R >R
      CS_OWNDC \ each window in the class has its own DC
      CS_HREDRAW OR
      CS_VREDRAW OR
      R> \ the address of the callback to use
      0 \ extra bytes for the class
      0 \ extra bytes for each window in the class
      HINST \ instance value of the executing program
      HINST 101 LoadIcon \ handle of the icon to represent it
      NULL IDC_ARROW LoadCursor \ the default cursor
      $d0ffff CreateSolidBrush
      0 \ no menu
      R> \ class name
   DefineClass ;
}

: Draw ( -- )
   hwndrw
        ?dup if 0 to hwndrw DestroyWindow drop then
   SubName drwproc DefaultClass DROP
   CreatDrWin DUP TO hwndrw
   DUP 0= ABORT" create window failed"
   DUP SW_SHOWNORMAL ShowWindow DROP
       UpdateWindow DROP ;

\ end skxl.txt

-----Original Message-----
From: sftalk-bounce_at_forth.com [mailto:sftalk-bounce_at_forth.com]On Behalf
Of Charley Shattuck
Sent: Monday, April 09, 2007 11:42 PM
To: sftalk_at_forth.com
Subject: [sftalk] Re: simple line drawing

Thanks Mike.

That's almost exactly what I was looking for. Is it hard to make the lines
persistent? They disappear if you move the window off screen and then bring
it back. Is that asking a lot?

Charley.

----------------------------------------------------------------------
sftalk_at_forth.com The SwiftForth programming discussion email list
To unsubscribe, send subject "unsubscribe" to sftalk-request_at_forth.com
For list command help, send subject "help" to sftalk-request_at_forth.com
Message archives are located at http://www.forth.com/archive/sftalk
----------------------------------------------------------------------
This list is a forum for SwiftForth users. For product support and
bug reports, please send email to support_at_forth.com
----------------------------------------------------------------------
Received on Tue Apr 10 2007 - 10:08:26 PDT