[Win32forth-cvs] win32for4web/downloads ClassBrowser.zip,NONE,1.1 DumpWindows.f,NONE,1.1 NUMBER.F,NO

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

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

Added Files:
	ClassBrowser.zip DumpWindows.f NUMBER.F STRUCT.F 
	ShellExecute.f Sockets.f ansify.f bezier.f blowfish.f color.f 
	dzfloat-test.zip isaac.f ods.f reorder.f tetris.f vibe-2.1.f 
Log Message:
Initial add

--- NEW FILE: vibe-2.1.f ---
\
\ VIBE Release 2.1
\ Copyright (c) 2001-2003 Samuel A. Falvo II
\ All Rights Reserved.
\
\ Highly portable block editor -- works under nearly every ANS Forth
\ I can think of, and with only a single screenful of words, will
\ work under Pygmy and FS/Forth too.
\
\ USAGE: vibe ( n -- ) Edits block 'n'.  Sets SCR variable to 'n'.
\        ed ( -- ) From Pygmy.  Re-edits last edited block.
\
\ I use CREATE instead of VARIABLE because I can statically initialize
\ the variables at load-time with no overhead.  Stole this idea from a7r
\ in the #Forth IRC channel.
\
\ 2.1 -- Fixed stack overflow bugs; forgot to DROP in the non-default
\        key handlers.
\
\
\ Ported to Win32Forth by Dirk Busch on March 8th, 2004

\ Win32Forth-specific
anew vibe.f
fload extras\block.f
char $ constant '$
char 0 constant '0

( Editor Constants )

\ I don't like this technique; should have used a bitmap.  Will fix later.
CHAR i CONSTANT 'i   \ Insert mode
CHAR r CONSTANT 'r   \ Replace mode
CHAR c CONSTANT 'c   \ Command mode

CHAR y CONSTANT 'y
CHAR n CONSTANT 'n

CHAR A CONSTANT 'A
CHAR Z CONSTANT 'Z

( Editor State )

\ 1 CREATE scr ,   \ Current block
 0 CREATE x ,     \ Cursor X position 0..63
 0 CREATE y ,     \ Cursor Y position 0..15
'c CREATE mode ,  \ Change to bitmap later.

\ GForth-specific
CREATE wordname 5 C, '$ C, '$ C, 0 C, 0 C, 0 C,

( Editor Display )

: mode. 63 0 AT-XY mode @ EMIT ;
: scr. 0 0 AT-XY ." Block: " scr @ . ."      " ;
: header. scr. mode. ;
: 8-s ." --------" ;
: 64-s 8-s 8-s 8-s 8-s 8-s 8-s 8-s 8-s ;
: border SPACE 64-s CR ;
: row DUP 64 TYPE 64 + ;
: line ." |" row ." |" CR ;
: 4lines line line line line ;
: 16lines scr @ BLOCK 4lines 4lines 4lines 4lines DROP ;
: card 0 1 AT-XY border 16lines border ;
: cursor x @ 1+ y @ 2 + AT-XY ;
: screen header. card cursor ;

( Editor State Control )

: insert 'i mode ! ;
: replace 'r mode ! ;
: cmd 'c mode ! ;

: (bounds) scr @ 0 MAX 65535 MIN scr ! ;
: prevblock -2 scr +! (bounds) ;
: nextblock  2 scr +! (bounds) ;
: toggleshadow 1 scr @ XOR scr ! ;

( Editor Cursor Control )

: flushLeft 0 x ! ;
: boundX x @ 0 MAX 63 MIN x ! ;
: boundY y @ 0 MAX 15 MIN y ! ;
: boundXY boundX boundY ;
: left -1 x +! boundXY ;
: right 1 x +! boundXY ;
: up -1 y +! boundXY ;
: down 1 y +! boundXY ;
\ : beep 7 EMIT ;
: nextline y @ 15 < IF flushLeft down THEN ;
: next x @ 63 = IF nextline EXIT THEN right ;

( Editor Insert/Replace Text )

: 64* 2* 2* 2* 2* 2* 2* ;
: (where) scr @ BLOCK SWAP 64* + SWAP + ;
: wh x @ y @ (where) ;
: eol 63 y @ (where) ;
: (place) wh C! UPDATE next ;
: -eol? x @ 63 < ;
: openr wh DUP 1+ 63 x @ - MOVE ;
: openRight -eol? IF openr THEN ;
: inserting? mode @ 'i = ;
: chr inserting? IF openRight THEN (place) ;

( Editor Commands: Quit, cursor, block, et. al. )

: $$c40 DROP 0 20 AT-XY R> R> DROP >R ; \ Q -- quits main loop
: $$c30 DROP flushLeft ;             \ 0
: $$c69 DROP insert ;                \ i
: $$c49 DROP flushLeft insert ;      \ I
: $$c52 DROP replace ;               \ R
: $$i1B DROP cmd ;                   \ (escape)
: $$c68 DROP left ;                  \ h
: $$c6A DROP down ;                  \ j
: $$c6B DROP up ;                    \ k
: $$c6C DROP right ;                 \ l
: $$c5B DROP prevblock ;             \ [
: $$c5C DROP toggleshadow ;          \ \
: $$c5D DROP nextblock ;             \ ]

( Editor Backspace/Delete )

: padding 32 eol C! UPDATE ;
: del wh DUP 1+ SWAP 63 x @ - MOVE ;
: delete -eol? IF del THEN padding ;
: bs left delete ;
: backspace x @ 0 > IF bs THEN ;

( Editor Carriage Return )

: nextln eol 1+ ;
: #chrs scr @ BLOCK 1024 + nextln - 64 - ;
: copydown y @ 14 < IF nextln DUP 64 + #chrs MOVE THEN ;
: blankdown nextln 64 32 FILL UPDATE ;
: splitdown wh nextln 2DUP SWAP - MOVE ;
: blankrest wh nextln OVER - 32 FILL ;
: opendown copydown blankdown ;
: (splitline) opendown splitdown blankrest ;
: retrn inserting? IF (splitline) THEN flushleft nextline ;
: return y @ 15 < IF retrn THEN ;

( Editor Wipe Block )

: ynmsg 0 20 AT-XY ." Are you sure? (Y/N) " ;
: valid? DUP 'n = OVER 'y = OR ;
: uppercase? DUP 'A >= SWAP 'Z <= AND ;
: lowercase DUP uppercase? IF $20 XOR THEN ;
: validkey BEGIN KEY lowercase valid? UNTIL ;
: clrmsg 0 20 AT-XY 64 SPACES ;
: no? ynmsg validkey clrmsg 'n = ;
: ?confirm no? IF R> DROP THEN ;
: wipescr ?confirm scr @ BLOCK 1024 32 FILL UPDATE 0 x ! 0 y ! ;

( Editor Commands: backspace, delete, et. al. )

: $$i04 DROP delete ;                    \ CTRL-D
: $$i08 DROP backspace ;                 \ (bs)
: $$i7F DROP backspace ;                 \ DEL -- for Unix
: $$i0D DROP return ;                    \ (cr)
: $$c5A DROP wipescr ;                   \ Z
: $$c6F DROP opendown down $$c49 ;       \ o
: $$c4F DROP opendown ;                  \ O

( Editor Keyboard Handler )

\ Word name key: $ $ _ _ _
\                    | | |
\ c = command mode --+ | |
\ i = ins/repl mode    | |
\                      | |
\ Key code (hex#) -----+-+
\
\ Called with ( k -- ) where k is the ASCII key code.

: keyboard KEY ;
: cmd? mode @ 'c = ;
: ins? mode @ 'i = mode @ 'r = OR ;
: mode! ins? 'i AND cmd? 'c AND OR wordname 3 + C! ;
: >hex DUP 9 > IF 7 + THEN '0 + ;
: h! DUP $F0 AND 2/ 2/ 2/ 2/ >hex wordname 4 + C! ;
: l! $0F AND >hex wordname 5 + C! ;
: name! mode! h! l! ;
: nomapping DROP ['] beep cmd? AND ['] chr ins? AND OR ;
: handlerword name! wordname FIND IF ELSE nomapping THEN ;
: keyboardhandler DUP handlerword EXECUTE ;
: editorloop BEGIN keyboard keyboardhandler screen AGAIN ;
: ed page screen editorloop ;
: vibe scr ! ed ;

\s 
10 create-blockfile c:\temp1.blk
1 vibe
close-blockfile

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

--- NEW FILE: NUMBER.F ---
anew number.f    \ March 12th, 2002 - 11:48

\ Shows numbers according to the international settings of the control panel.
\ March 11th, 2002 - 14:57 changed init_digits.
\ Now it seems to be right for various windows-systems

\ January 24th, 2004 - 12:43 dbu
\ - Made this source independed from toolset.f

[UNDEFINED] hld-max [IF]
        80 constant hld-max
[THEN]

[UNDEFINED] hld-count [IF]
        : hld-count  ( count - hld count-1 )  hld swap 1- ;
[THEN]

[UNDEFINED] fvalue-to-string [IF]
        synonym fvalue-to-string (f.)
[THEN]

: s(d.#)   ( d1 n1 sign -- a1 count ) \ display d1 with n1 places behind DP
    >r  >r <#
    r>  ?dup            \ if not zero, then display places
        if   0 max 0
             ?do #
             loop [char] . hold
        then
    #s r>
        if   [char] - hold   \ including the sign
        then
    #>
    ;

: lprep  ( l h n1 sign - base hld-max hld_abs 0 adr$ 0 LOCALE_SYSTEM_DEFAULT )
   2>r base @ -rot decimal
   2>r  hld-max hld rel>abs 0 2r>
   pad 30 erase 2r> s(d.#) drop  rel>abs 0 LOCALE_SYSTEM_DEFAULT
 ;

: lfprep ( f: f - ) ( - base hld-max hld_abs 0 adr$ 0 LOCALE_SYSTEM_DEFAULT )
   base @ decimal hld-max hld rel>abs 0
   pad 30 erase pad fvalue-to-string pad 1+ rel>abs 0 LOCALE_SYSTEM_DEFAULT
 ;

0 value #idigits
0 value #iCurrDigits

: digit@>s   ( adr - digit   )  c@ 0xf and ;
: reg-digit@ ( adr n - digit )  drop digit@>s ;

: no_idigits ( count - count_without_the_idigits )
   #idigits 0>
      if    #idigits - 1-
      then
 ;

: type-r ( adr count right-justify - )
  2dup >=
     if    drop
     else  over - spaces
     then  type
 ;

: dsigned?   ( l h - ul hl sign ) 2dup dabs 2swap d0< ;

: (l.$fin)   ( l h - adr count )
   dsigned? #iCurrDigits swap lprep
   call GetCurrencyFormat hld-count rot base !
 ;
: (l.ud)     ( l h n1 sign  - adr count ) \ max: +/- -18.446.744.073.709.551.615
    lprep call GetNumberFormat hld-count rot base ! ;

: (l.d)      ( l h n1  - adr count ) >r dsigned? r> swap (l.ud) ;
: (l.dint)   ( l h - adr count )     0 (l.d) no_idigits ; \ January 11th, 2002
: (l.int)    ( n -  adr count )      s>d (l.dint) ;       \ January 11th, 2002
: l.ud       ( l h - )               #idigits false (l.ud) type ;
: l.d        ( l h - )               #idigits (l.d) type ;
: l.         ( n - )                 s>d l.d ;
: l.int      ( n - )                 (l.int)  type ;
: l.d$fin    ( l h - )               (l.$fin) type ;
: l.$fin     ( n - )                 s>d l.d$fin ;
: l.dr       ( r l h - )             #idigits (l.d) rot type-r ;
: l.r        ( n r - )               swap s>d l.dr ;
: l.intr     ( n r - )               swap s>d 0 (l.d) no_idigits rot type-r ;
: l.d$finr   ( l h r - )             -rot (l.$fin) rot type-r ;
: l.$finr    ( n r - )               swap s>d rot l.d$finr ;

: (l.f)        ( f: f - adr count )  \ not very accurate when B/FLOAT is 8
   precision 26 set-precision lfprep
   call GetNumberFormat hld-count rot base ! rot set-precision
 ;

: l.f        ( f: f - ) (l.f) type ;
: l.fr       ( r - )  ( f: f - ) (l.f) rot type-r ;

: #zeros-in$? ( adr count - #zeros )
    0 swap 0    do    over i + c@ ascii 0 = abs +    loop  nip ;

: init_digits  ( - )
   1 0 0 (l.d)    #zeros-in$? to #idigits
   1 0   (l.$fin) #zeros-in$? to #iCurrDigits
 ;

initialization-chain chain-add init_digits
init_digits

((  ( Remove or disable this line to see the demo )

\ Usage:

cr -1234e  l.f
cr  123.4e l.f
cr
cr -12e      12 l.fr
cr  123.4e   12 l.fr
cr -12345e   12 l.fr
cr  1239.47e 12 l.fr

cr
cr 9841  l.
cr -9841 l.int

cr
cr -12345 10 l.intr
cr 123    10 l.intr
cr 1      10 l.intr
cr 12345  10 l.r

cr \ The Euro-sign will be shown when it is in the current font.
cr -1234567 l.$fin
cr
cr -1234567 15 l.$finr
cr    12345 15 l.$finr
cr      -12 15 l.$finr

cr
cr  1  1 l.ud
cr -1 -1 l.ud

: .GetProcessWorkingSetSize
   hld rel>abs
   hld 4 + rel>abs
   call GetCurrentProcess
   call GetProcessWorkingSetSize ?win-error
   hld 4 + @ hld @
   cr 10 ." Maximum working set size" l.intr
   cr 10 ." Minimum working set size" l.intr
 ;
cr .GetProcessWorkingSetSize cr \ ))

 \s

--- NEW FILE: ansify.f ---
\ Convert ANSI Forth standard definition names from lower to upper case.

\ $Id: ansify.f,v 1.1 2005/06/12 08:14:46 dbu_de Exp $ 

\ This file contains code to convert ANSI Forth source code
\ with standard definition names written in lower case (environmental 
\ dependency) to source code with standard definition names written in
\ UPPER case. It thus helps porting ANSI Forth code written for case
\ insensitive systems to case sensitive systems.

\ Comments, hints and bug reports are welcome. Please email
\ to 
\                    uh...@pi...
\                               or
\                    uh...@in...

\                      Ulrich Hoffmann
\                      Sehestedter Strasse 26 
\                      24340 Eckernfoerde
\                      Germany

\ Thanks to J.Plewe for his helpful hints.
\ ---------------------------------------------------------------------------

\ This is an ANS-Forth program
\    -  Requiring  
\       .( 0> ?DO FALSE MARKER NIP TO TRUE U> VALUE WITHIN \   
\       from the Core Extensions word set,
\    -  Requiring the File-Access word set,
\    -  Requiring the Search-Order word set,
\    -  Requiring FORTH from the Search-Order Extensions word set
\    -  Requiring the String word set.

\ Required program documentation
\
\    - Environmental dependencies
\         This program has no known environmental dependencies.
\    - Other program documentation
\         This program requires to output text via the standard words
\         .( ABORT" and EMIT
\         After loading this program, a Standard System still exists.

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

\ From the draft proposed standard:

\ 3.4.2 ... A system may be either case sensitive, treating
\ upper- and lower-case letters as different and not matching,
\ or case insensitive, ignoring differences in case while searching.

\ 3.3.1.2 ... Programs that use lower case for standard definition
\ names or depend on the case-sensitivity properties of a system have
\ an environmental dependency.

anew ansify.f

\ : umin ( u1 u2 -- u3 )
\   \ Which is the smaller one? u1 or u2?
\   2DUP U> IF  SWAP  THEN  DROP ;

: /string' ( c-addr1 u1 n -- c-addr2 u2 )
   \ Define /string with a known behaviour for n>u1
   DUP 0> IF  OVER umin  THEN
   /STRING ;

\ : place ( c-addr len c-addr' -- )
\   \ Put the string given by C-ADDR LEN as counted string at address C-ADDR'
\   2DUP C!  CHAR+ SWAP CMOVE ;

\ : skip  ( addr len c -- addr' len' )
\   \ Within the string given by ADDR and LEN skip leading occurances of
\   \ character C. Return the remaining string denoted by ADDR' and LEN'.
\   >R
\   BEGIN ( addr len )
\     OVER C@ R@ =
\   WHILE
\     1 /string'
\     DUP 0=
\   UNTIL THEN
\   R> DROP ;

\ : scan  ( addr len c -- addr' len' )
\    \ Within the string given by ADDR and LEN scan for the first occurances
\    \ of character C. Return the remaining string denoted by ADDR' and LEN'.
\    >R
\    BEGIN ( addr len )
\      OVER C@ R@ -
\    WHILE
\      1 /string'
\      DUP 0=
\    UNTIL THEN
\    R> DROP ;

\ : uppercase ( c -- C )
\   \ Convert character to uppercase.
\    DUP [CHAR] a [CHAR] z 1+ WITHIN IF [ CHAR A CHAR a - ] LITERAL + THEN ;

\ : upper ( addr len -- )
\   \ Convert string to uppercase.
\   OVER + SWAP ?DO  I C@  uppercase  I C!  LOOP ;

CREATE search$ 64 CHARS ALLOT   ( buffer to hold search strings )

: find-list  ( addr len list -- xt true | 0 false ) 
   \ Look for capitalized string given by ADDR LEN in the 
   \ word list denoted by LIST. If search is succesful 
   \ return the appropriate execution token and true,
   \ else return a dummy 0 and false.
   >R  
   SWAP OVER  search$ SWAP CMOVE  
   search$ SWAP   2DUP upper  
   R> SEARCH-WORDLIST 
   IF  TRUE EXIT THEN
   0 FALSE ; 

: Capitalize: ( <name> -- )
  \ Define a word, which when executed will capitalize a string.
    CREATE
  DOES> DROP ( addr len -- ) upper ;

: Verbatim: ( <name> c -- )
  \ Define a word, which when executed will capitalize a string
  \ and then will scan in another string for a given delimiter.
    CREATE C,
  DOES> C@ >R ( addr' len' addr len -- addr' len' )
    upper
    R> scan  1 /string' ;

WORDLIST CONSTANT <standard-words>  

<standard-words> SET-CURRENT

  CHAR " Verbatim: "
  CHAR " Verbatim: ."
  CHAR " Verbatim: ABORT"
  CHAR ) Verbatim: .(
  CHAR " Verbatim: C"
  CHAR " Verbatim: S"
  CHAR ) Verbatim: (
  -1     Verbatim: \

\ Capitalize: !
\ Capitalize: #
\ Capitalize: #>
  Capitalize: #S
  Capitalize: #TIB
\ Capitalize: (
\ Capitalize: '
  Capitalize: (LOCAL)
\ Capitalize: *
\ Capitalize: */
  Capitalize: */MOD
\ Capitalize: +
\ Capitalize: +!
  Capitalize: +LOOP
\ Capitalize: ,
\ Capitalize: -
  Capitalize: -TRAILING
\ Capitalize: .
\ Capitalize: ."
\ Capitalize: .(
  Capitalize: .R
  Capitalize: .S
\ Capitalize: /
  Capitalize: /MOD
  Capitalize: /STRING
\ Capitalize: 0<
\ Capitalize: 0<>
\ Capitalize: 0=
\ Capitalize: 0>
\ Capitalize: 1+
\ Capitalize: 1-
\ Capitalize: 2!
\ Capitalize: 2*
\ Capitalize: 2/
  Capitalize: 2>R
\ Capitalize: 2@
  Capitalize: 2CONSTANT
  Capitalize: 2DROP
  Capitalize: 2DUP
  Capitalize: 2LITERAL
  Capitalize: 2OVER
\ Capitalize: 2R>
\ Capitalize: 2R@
  Capitalize: 2ROT
  Capitalize: 2SWAP
  Capitalize: 2VARIABLE
\ Capitalize: :
  Capitalize: :NONAME
\ Capitalize: ;
  Capitalize: ;CODE
\ Capitalize: <
\ Capitalize: <#
\ Capitalize: <>
\ Capitalize: =
\ Capitalize: >
  Capitalize: >BODY
  Capitalize: >FLOAT
  Capitalize: >IN
  Capitalize: >NUMBER
  Capitalize: >R
\ Capitalize: ?
  Capitalize: ?DO
  Capitalize: ?DUP
\ Capitalize: @
  Capitalize: ABORT
\ Capitalize: ABORT"
  Capitalize: ABS
  Capitalize: ACCEPT
  Capitalize: AGAIN
  Capitalize: AHEAD
  Capitalize: ALIGN
  Capitalize: ALIGNED
  Capitalize: ALLOCATE
  Capitalize: ALLOT
  Capitalize: ALSO
  Capitalize: AND
  Capitalize: ASSEMBLER
  Capitalize: AT-XY
  Capitalize: BASE
  Capitalize: BEGIN
  Capitalize: BIN
  Capitalize: BL
  Capitalize: BLANK
  Capitalize: BLK
  Capitalize: BLOCK
  Capitalize: BUFFER
  Capitalize: BYE
  Capitalize: C!
\ Capitalize: C"
  Capitalize: C,
  Capitalize: C@
  Capitalize: CASE
  Capitalize: CATCH
  Capitalize: CELL+
  Capitalize: CELLS
  Capitalize: CHAR
  Capitalize: CHAR+
  Capitalize: CHARS
  Capitalize: CLOSE-FILE
  Capitalize: CMOVE
  Capitalize: CMOVE>
  Capitalize: CODE
  Capitalize: COMPARE
  Capitalize: COMPILE,
  Capitalize: CONSTANT
  Capitalize: CONVERT
  Capitalize: COUNT
  Capitalize: CR
  Capitalize: CREATE
  Capitalize: CREATE-FILE
  Capitalize: CS-PICK
  Capitalize: CS-ROLL
  Capitalize: D+
  Capitalize: D-
  Capitalize: D.
  Capitalize: D.R
  Capitalize: D0<
  Capitalize: D0=
  Capitalize: D2*
  Capitalize: D2/
  Capitalize: D<
  Capitalize: D=
  Capitalize: D>F
  Capitalize: D>S
  Capitalize: DABS
  Capitalize: DECIMAL
  Capitalize: DEFINITIONS
  Capitalize: DELETE-FILE
  Capitalize: DEPTH
  Capitalize: DF!
  Capitalize: DF@
  Capitalize: DFALIGN
  Capitalize: DFALIGNED
  Capitalize: DFLOAT+
  Capitalize: DFLOATS
  Capitalize: DMAX
  Capitalize: DMIN
  Capitalize: DNEGATE
  Capitalize: DO
  Capitalize: DOES>
  Capitalize: DROP
  Capitalize: DU<
  Capitalize: DUMP
  Capitalize: DUP
  Capitalize: EDITOR
  Capitalize: EKEY?
  Capitalize: EKEY>CHAR
  Capitalize: EKEY
  Capitalize: ELSE
  Capitalize: EMIT
  Capitalize: EMIT?
  Capitalize: EMPTY-BUFFERS
  Capitalize: ENDCASE
  Capitalize: ENDOF
  Capitalize: ENVIRONMENT?
  Capitalize: ERASE
  Capitalize: EVALUATE
  Capitalize: EXECUTE
  Capitalize: EXIT
  Capitalize: EXPECT
  Capitalize: F!
  Capitalize: F*
  Capitalize: F**
  Capitalize: F+
  Capitalize: F-
  Capitalize: F.
  Capitalize: F/
  Capitalize: F0<
  Capitalize: F0=
  Capitalize: F<
  Capitalize: F>D
  Capitalize: F@
  Capitalize: FABS
  Capitalize: FACOS
  Capitalize: FACOSH
  Capitalize: FALIGN
  Capitalize: FALIGNED
  Capitalize: FALOG
  Capitalize: FALSE
  Capitalize: FASIN
  Capitalize: FASINH
  Capitalize: FATAN
  Capitalize: FATAN2
  Capitalize: FATANH
  Capitalize: FCONSTANT
  Capitalize: FCOS
  Capitalize: FCOSH
  Capitalize: FDEPTH
  Capitalize: FDROP
  Capitalize: FDUP
  Capitalize: FE.
  Capitalize: FEXP
  Capitalize: FEXPM1
  Capitalize: FILE-POSITION
  Capitalize: FILE-SIZE
  Capitalize: FILE-STATUS
  Capitalize: FILL
  Capitalize: FIND
  Capitalize: FLITERAL
  Capitalize: FLN
  Capitalize: FLNP1
  Capitalize: FLOAT+
  Capitalize: FLOATS
  Capitalize: FLOG
  Capitalize: FLOOR
  Capitalize: FLUSH
  Capitalize: FLUSH-FILE
  Capitalize: FM/MOD
  Capitalize: FMAX
  Capitalize: FMIN
  Capitalize: FNEGATE
  Capitalize: FORGET
  Capitalize: FORTH
  Capitalize: FORTH-WORDLIST
  Capitalize: FOVER
  Capitalize: FREE
  Capitalize: FROT
  Capitalize: FROUND
  Capitalize: FS.
  Capitalize: FSIN
  Capitalize: FSINCOS
  Capitalize: FSINH
  Capitalize: FSQRT
  Capitalize: FSWAP
  Capitalize: FTAN
  Capitalize: FTANH
  Capitalize: FVARIABLE
  Capitalize: F~
  Capitalize: GET-CURRENT
  Capitalize: GET-ORDER
  Capitalize: HERE
  Capitalize: HEX
  Capitalize: HOLD
  Capitalize: I
  Capitalize: IF
  Capitalize: IMMEDIATE
  Capitalize: INCLUDE-FILE
  Capitalize: INCLUDED
  Capitalize: INVERT
  Capitalize: J
  Capitalize: KEY
  Capitalize: KEY?
  Capitalize: LEAVE
  Capitalize: LIST
  Capitalize: LITERAL
  Capitalize: LOAD
  Capitalize: LOCALS|
  Capitalize: LOOP
  Capitalize: LSHIFT
  Capitalize: M*
  Capitalize: M*/
  Capitalize: M+
  Capitalize: MARKER
  Capitalize: MAX
  Capitalize: MIN
  Capitalize: MOD
  Capitalize: MOVE
  Capitalize: MS
  Capitalize: NEGATE
  Capitalize: NIP
  Capitalize: OF
  Capitalize: ONLY
  Capitalize: OPEN-FILE
  Capitalize: OR
  Capitalize: ORDER
  Capitalize: OVER
  Capitalize: PAD
  Capitalize: PAGE
  Capitalize: PARSE
  Capitalize: PICK
  Capitalize: POSTPONE
  Capitalize: PRECISION
  Capitalize: PREVIOUS
  Capitalize: QUERY
  Capitalize: QUIT
  Capitalize: R/O
  Capitalize: R/W
  Capitalize: R>
  Capitalize: R@
  Capitalize: READ-FILE
  Capitalize: READ-LINE
  Capitalize: RECURSE
  Capitalize: REFILL
  Capitalize: RENAME-FILE
  Capitalize: REPEAT
  Capitalize: REPOSITION-FILE
  Capitalize: REPRESENT
  Capitalize: RESIZE
  Capitalize: RESIZE-FILE
  Capitalize: RESTORE-INPUT
  Capitalize: ROLL
  Capitalize: ROT
  Capitalize: RSHIFT
\ Capitalize: S"
  Capitalize: S>D
  Capitalize: SAVE-BUFFERS
  Capitalize: SAVE-INPUT
  Capitalize: SCR
  Capitalize: SEARCH
  Capitalize: SEARCH-WORDLIST
  Capitalize: SEE
  Capitalize: SET-CURRENT
  Capitalize: SET-ORDER
  Capitalize: SET-PRECISION
  Capitalize: SF!
  Capitalize: SF@
  Capitalize: SFALIGN
  Capitalize: SFALIGNED
  Capitalize: SFLOAT+
  Capitalize: SFLOATS
  Capitalize: SIGN
  Capitalize: SLITERAL
  Capitalize: SM/REM
  Capitalize: SOURCE
  Capitalize: SOURCE-ID
  Capitalize: SPACE
  Capitalize: SPACES
  Capitalize: SPAN
  Capitalize: STATE
  Capitalize: SWAP
  Capitalize: THEN
  Capitalize: THROW
  Capitalize: THRU
  Capitalize: TIB
  Capitalize: TIME&DATE
  Capitalize: TO
  Capitalize: TRUE
  Capitalize: TUCK
  Capitalize: TYPE
  Capitalize: U.
  Capitalize: U.R
  Capitalize: U<
  Capitalize: U>
  Capitalize: UM*
  Capitalize: UM/MOD
  Capitalize: UNLOOP
  Capitalize: UNTIL
  Capitalize: UNUSED
  Capitalize: UPDATE
  Capitalize: VALUE
  Capitalize: VARIABLE
  Capitalize: W/O
  Capitalize: WHILE
  Capitalize: WITHIN
  Capitalize: WORD
  Capitalize: WORDLIST
  Capitalize: WORDS
  Capitalize: WRITE-FILE
  Capitalize: WRITE-LINE
  Capitalize: XOR
\ Capitalize: [
\ Capitalize: [']
  Capitalize: [CHAR]
  Capitalize: [COMPILE]
  Capitalize: [ELSE]
  Capitalize: [IF]
  Capitalize: [THEN]
\ Capitalize: \
\ Capitalize: ]

\ FORTH-WORDLIST SET-CURRENT
FORTH DEFINITIONS

: ansify-line ( addr len -- )
    \ Process a source text line given by ADDR and LEN.
    BEGIN ( addr len )
      BL skip DUP 0= IF ( eoln ) 2DROP EXIT THEN
      2DUP BL scan    ( addr len addr' len' )
      2SWAP  2OVER    ( addr' len'  addr len  addr' len' )
      NIP -           ( addr' len' addr l )
      2DUP <standard-words> find-list
      IF ( addr' len' addr l xt ) EXECUTE ( addr' len' )
      ELSE  ( addr' len' addr l 0 )  DROP 2DROP THEN
      DUP 0=
    UNTIL ( eoln )
    2DROP ;

1024 CONSTANT bufsize  \ maximal size lines can have
CREATE line  bufsize 2 + ( newline chars )  CHARS ALLOT

: getline ( fileid -- addr len flag )
   \ Read a line of text from the file denoted by FILEID.
   \ If the end of file is reached, return two dummy values and false
   \ If a line could be read succesfully return its address and
   \ length along with a true flag.
   line bufsize ROT READ-LINE ABORT" getline: read error!"
   0= IF ( eof )  0 FALSE EXIT THEN
   line SWAP TRUE ;

: putline ( addr len fileid -- )
   \ Write the line denoted by ADDR and LEN to the file given by FILEID.
   WRITE-LINE ABORT" putline: write error! " ;

0 VALUE input   ( input  file id )
0 VALUE output  ( output file id )

: fansify ( infile outfile -- ) TO output  TO input
    \ Convert the file given by the fileid INFILE and store the result
    \ in the file denoted by the fileid OUTFILE
    BEGIN
      input getline   
      [CHAR] . EMIT      \ Show progress.
    WHILE
      2DUP ansify-line
      output putline
    REPEAT
    2DROP ;

: ansify-file ( addr-in len-in addr-out len-out -- )
    \ Expect two strings, the names of the input file and the name of
    \ the output file. Convert the input file and write the result
    \ to the output file.
    R/W CREATE-FILE  ABORT" Cannot create output file!" >R ( outfileid )
    R/O OPEN-FILE    ABORT" Cannot open input file!"       ( infileid )
    DUP R@ fansify
    CLOSE-FILE DROP
    R> CLOSE-FILE DROP ;

CREATE inname  64 ALLOT    \ Name of input file
CREATE outname 64 ALLOT    \ Name of output file

: ansify ( <inname> <outname> -- )
    \ User word.  Used in the form  ansify <inname> <outname>
    \ to convert the file with name <inname> and put the result
    \ in the file with name <outname>
    BL WORD  COUNT   inname  place
    BL WORD  COUNT   outname place
    inname COUNT  outname COUNT ansify-file ;

CR .( ansify <inname> <outname> )

--- NEW FILE: ods.f ---
\    File: ODS.f
\  Author: Dirk Busch
\ Created: January 19th, 2004 - dbu
\ Updated: January 24th, 2004 - dbu
\
\ OutputDebugString() support for Win32Forth

cr .( Loading Output-Debug-String support)

anew ods.f

INTERNAL

VARIABLE ods?       \ enable/disable ODS

EXTERNAL

: ods-on ( -- )     \ enable ODS
        ods? ON ;

: ods-off ( -- )    \ disable ODS
        ods? OFF ;

1 PROC OutputDebugString
: ods   ( addr -- ) \ sends a string to the Windows Debug Window
                    \ (e.g. 'DebugView' from www.sysinternals.com)
                    \ for display
        ods?
        IF   REL>ABS CALL OutputDebugString DROP
        ELSE DROP
        THEN ;

: d.ods ( d -- ) { \ buf$ -- }
        (D.) DUP 1+ LOCALALLOC ASCII-Z TO buf$
        buf$ ods ;

: .ods  ( n -- )
        0 d.ods ;

: ods"  ( -<text">- -- )
        STATE @
        IF   POSTPONE (Z") ,"  POSTPONE ods
        ELSE [char] " WORD
             NEW$ DUP>R OVER C@ 1+ MOVE
             R@ COUNT + OFF
             R> 1+ ods
        THEN ; IMMEDIATE

ods-on \ enable ODS by default

MODULE

--- NEW FILE: isaac.f ---
\ Copyright 1997 Pierre Henri Michel Abbat as a derivative work.
\ Translated from Bob Jenkins' C code.
\ See R. Jenkins, "ISAAC", LNCS 1039 (Fast Software Encryption), pp 41-49, February 1996.
\ http://burtleburtle.net/bob/

\ Anyone may use this code freely, as long as credit is given.

\ isaac.f translated from Bob Jenkins' rand.c
\ This version works in Win32Forth
\ The code will work with or without optimization; it is
\  significantly faster optimized. There is a bug in the
\  optimizer: If you load the optimizer, then load any file
\  using anew three times without clearing the name cache,
\  Forth will complain that the marker is in the protected
\ dictionary.

\ needs optimize
\ hidden >name-cache-init forth
in-application
anew isaac-random-number-generator

hex

: range   over + swap ;
100 constant randsiz
8 constant randsizl ( base 2 log of randsiz )
create randrsl  randsiz cells allot
variable randptr ( like randcnt in C )
create mm  randsiz cells allot ( internal state of isaac )
variable aa  aa off
variable bb  bb off
variable cc  cc off

code 5roll      ( n1 n2 n3 n4 n5 n6 -- n2 n3 n4 n5 n6 n1 )
( This occurs three times in rngstep, and the "optimizer"
  turns it into a long code sequence. )
        xchg    ebx,    0 [esp]
        xchg    ebx,    4 [esp]
        xchg    ebx,    8 [esp]
        xchg    ebx,    c [esp]
        xchg    ebx,    10 [esp]
        next    c;

\ opt-on

: ind ( u - u' )
( Given u, produces one of the elements of mm. )
  [ randsiz 1- cells ] literal and  mm + @ ;

: rngstep ( a b m m2 r mix - a' b' m+4 m2+4 r+4 )
  5roll xor 2 pick @ +                  ( b m m2 r a' )
  3 pick @ swap 5roll                   ( m m2 r x a' b )
  2dup 4 pick ind + + dup 7 pick ! nip  ( m m2 r x a' y )
  randsizl rshift ind rot + dup         ( m m2 r a' b' b' )
  2rot cell+ swap cell+ swap            ( r a' b' b' m+4 m2+4 )
  rot 5roll tuck ! cell+                ( a' b' m+4 m2+4 r+4 ) ;

\ opt-off

: isaac
  aa @ 1 cc +! cc @ bb @ + mm dup randsiz cells 2/ + randrsl
  randsiz 2/ 0 do
    4 pick 0d lshift rngstep
    4 pick 06 rshift rngstep
    4 pick 02 lshift rngstep
    4 pick 10 rshift rngstep
  4 +loop
  nip mm swap
  randsiz 2/ 0 do
    4 pick 0d lshift rngstep
    4 pick 06 rshift rngstep
    4 pick 02 lshift rngstep
    4 pick 10 rshift rngstep
  4 +loop
  3drop bb ! aa ! ;

: reset-isaac
  aa off bb off cc off randptr off
  mm randsiz cells erase ;

: test
  reset-isaac
  0a 0 do isaac loop
  aa @ u. bb @ u. cc @ u. ;

randptr off

: rand
  randptr @ randrsl < if
    isaac
    randrsl randsiz 1- cells + randptr !
  then
  randptr @ @  -cell randptr +! ;

: isaac256
( every 256th result of isaac, to be tested for bias )
  isaac mm @ ;

: test256 ( n - )
  0 ?do isaac256 ( 10 u.r ) drop loop ;

( Initialization of the random number generator with or without a seed )

: -roll
( This is slow code, but it's used only in the initialization! )
  dup 1+ swap
  0 ?do
    dup roll swap
  loop drop ;

: 8@
  8 cells +
  8 0 do
    cell- dup @ swap
  loop drop ;

: 8!
  8 cells range do
    i !
  cell +loop ;

: 8+!
  8 cells range do
    i +!
  cell +loop ;

: (nextnum)
  -rot over + 2swap tuck + swap 2swap rot 7 -roll ;

: mix ( h g f e d c b a - h' g' f' e' d' c' b' a' )
  over 0b lshift xor  (nextnum)
  over 02 rshift xor  (nextnum)
  over 08 lshift xor  (nextnum)
  over 10 rshift xor  (nextnum)
  over 0a lshift xor  (nextnum)
  over 04 rshift xor  (nextnum)
  over 08 lshift xor  (nextnum)
  over 09 rshift xor  (nextnum)
  ;

: randinit ( ? )
( Initializes isaac. If the argument is 0, use a default initialization;
  otherwise, use the contents of randrsl to compute the seed. )
  reset-isaac
  >r ( save flag )
  9e3779b9 dup 2dup 2dup 2dup mix mix mix mix
  r@ not if randrsl randsiz cells erase then

 randrsl randsiz cells range do
    i 8+! i 8@ mix i mm + randrsl - dup>r 8! r> 8@
  8 cells +loop
  r> if
    mm randsiz cells range do
      i 8+! i 8@ mix i 8! i 8@
    8 cells +loop
  then
  2drop 2drop 2drop 2drop ;

: test768
( Outputs the first 768 numbers generated by isaac
  initialized with randrsl zeroed. The second and third
  256 are the numbers in randvect.txt backward in two groups. )
  randrsl randsiz cells erase
  true randinit
  base @ hex
  300 0 do
    i 8 mod 0= if cr then
    rand 9 u.r
  loop
  base ! ;

create randsave randsiz cells allot
: test-change
  false randinit isaac
  randrsl randsave randsiz cells move
  false randinit 400 mm +! isaac
  randrsl randsave randsiz 0 do
    i 0f and 0= if cr then
    over @ over @ = if ascii . else ascii * then emit
    cell+ swap cell+ swap
  loop
  2drop ;

decimal

--- NEW FILE: Sockets.f ---
\  Windows Sockets of Andrey Cherezov

anew sockets.f

winlibrary wsock32.dll

1  CONSTANT SOCK_STREAM
-1 CONSTANT INVALID_SOCKET
-1 CONSTANT SOCKET_ERROR
2  CONSTANT PF_INET
2  CONSTANT AF_INET
6  CONSTANT IPPROTO_TCP

NOSTACK \ A tip from: Alex McDonald October 16th, 2002

0
2 FIELD+ sin_family
2 FIELD+ sin_port
4 FIELD+ sin_addr
8 FIELD+ sin_zero
CONSTANT /sockaddr_in
CREATE sock_addr HERE /sockaddr_in DUP ALLOT ERASE
AF_INET sock_addr sin_family W!

CHECKSTACK

: ASCIIZ>  100 2dup 0 scan nip - ;
: ztype ( z"a -- )
  ASCIIZ>   type ;

: CreateSocket ( -- socket ior )
  IPPROTO_TCP SOCK_STREAM PF_INET
  call socket DUP INVALID_SOCKET =
  IF call WSAGetLastError
  ELSE 0 THEN
;
: ToRead ( socket -- n ior )
  \ ñêîëüêî áàéò ìîæíî ñåé÷àñ ïðî÷åñòü èç ñîêåòà
  \ ìîæíî èñïîëüçîâàòü ïåðåä ReadSocket äëÿ òîãî ÷òîáû
  \ èçáåæàòü áëîêèðîâàíèÿ ïðè n=0
  0 >r
  rp@ REL>ABS [ HEX ] 4004667F [ DECIMAL ] ROT
  call ioctlsocket SOCKET_ERROR =
  IF r>drop 0 call WSAGetLastError ELSE r> 0 THEN
;
: ConnectSocket ( IP port socket -- ior )
  >R
  256 /MOD SWAP 256 * +
  sock_addr sin_port W!
  sock_addr sin_addr !
  /sockaddr_in sock_addr REL>ABS R> call connect SOCKET_ERROR =
  IF call WSAGetLastError ELSE 0 THEN
;
: CloseSocket ( s -- ior )
  call closesocket SOCKET_ERROR =
  IF call WSAGetLastError ELSE 0 THEN
;

: WriteSocket ( addr u s -- ior )
  >r 0 swap rot REL>ABS r>   \  0 u addr s
  call send SOCKET_ERROR =
  IF call WSAGetLastError ELSE 0 THEN
;
: SWrite ( addr u s -- wlen )
  >r 0 swap rot REL>ABS r>   \  0 u addr s
  call send
;
: WriteSocketLine ( addr u s -- ior )
  DUP >R WriteSocket ?DUP IF R> DROP EXIT THEN
  crlf$ COUNT R> WriteSocket
;
: WriteSocketCRLF ( s -- ior )
  HERE 0 ROT WriteSocketLine
;
: ReadSocket ( addr u s -- rlen ior )
   >r 0 swap rot REL>ABS r>   \  0 u addr s
  call recv DUP SOCKET_ERROR =
  IF call WSAGetLastError ELSE 0 THEN
  OVER 0= IF DROP -1002 THEN
  ( åñëè ïðèíÿòî 0, òî îáðûâ ñîåäèíåíèÿ )
;
: SRead ( addr u s -- r )
  >r 0 swap rot REL>ABS r>   \  0 u addr s
  call recv
;
CODE a>r@      ( a1 -- n1 )
                mov     ebx, 0 [ebx]
                next    c;

: GetHostName ( IP -- addr u ior )
  >r PF_INET 4 rp@ REL>ABS call gethostbyaddr
  ?DUP IF A>R@ ABS>REL ASCIIZ> 0
       ELSE HERE 0 call WSAGetLastError
       THEN  r>drop
;
: Get.Host.Name ( addr u -- addr u ior )
  DROP REL>ABS call inet_addr GetHostName
;
: zGetHostIP ( z" -- IP ior )
  dup c@ [char] 0 [char] 9 between over and
  if rel>abs call inet_addr 0
  else dup if REL>ABS then call gethostbyname DUP
       IF  3 CELLS + A>R@ A>R@ A>R@ 0
       ELSE call WSAGetLastError
       THEN
  then
;

\ changed Samstag, Mai 15 2004 - 13:20 dbu
create my-ip-addr-buf 256 allot
0 my-ip-addr-buf !
: my-ip-addr ( -- IP )
        my-ip-addr-buf zGetHostIP drop ;

: GetHostIP ( addr len -- IP ior )
  RP@ 265 - RP!
  RP@ 265 ERASE
  RP@ SWAP 265 UMIN CMOVE
  RP@ zGetHostIP
  RP@ 265 + RP!
;
CREATE sock_addr2 HERE /sockaddr_in DUP ALLOT ERASE
AF_INET sock_addr2 sin_family W!

: GetPeerName ( s -- addr u ior )
  /sockaddr_in >r
  rp@ REL>ABS sock_addr2 REL>ABS ROT call getpeername SOCKET_ERROR =
  IF HERE 0 call WSAGetLastError
  ELSE sock_addr2 sin_addr @ GetHostName THEN  r>drop
;
: SocketsStartup ( -- ior )
  HERE rel>abs 257 call WSAStartup
;
: SocketsCleanup ( -- ior )
  call WSACleanup
;
: BindSocket ( port s -- ior )
  >R /sockaddr_in ALLOCATE ?DUP IF NIP R> DROP EXIT THEN
  >R
  256 /MOD SWAP 256 * +
  R@ sin_port W!
  AF_INET R@ sin_family W!
  R@
  0 R@ sin_addr !
  /sockaddr_in R> REL>ABS R> call bind SWAP FREE DROP SOCKET_ERROR =
  IF call WSAGetLastError ELSE 0 THEN
;
: ListenSocket ( s -- ior )
  2 SWAP call listen SOCKET_ERROR =
  IF call WSAGetLastError ELSE 0 THEN
;
CREATE SINLEN /sockaddr_in ,

: SOCKET-ACCEPT  { ADDR ALEN FH -- s2 ior }
   &LOCAL ALEN REL>ABS ADDR REL>ABS  FH call accept
   DUP INVALID_SOCKET =
   IF call WSAGetLastError ELSE 0 THEN
;

 :  #IP   ( du -- 0 )
           #S  [CHAR] . HOLD  2DROP 0
 ;
 : (.IP)  ( IP -- addr u )
  0 256 UM/MOD 0 256 UM/MOD 0 256 UM/MOD
        0 <#   \  0      HOLD
           #IP #IP #IP #S #> ;
: NtoA (.IP) ;

: CLIENT-OPEN ( addr u port -- s  )
       >r GetHostIP abort" Server not available "
       r> CreateSocket DROP DUP >r
       ConnectSocket abort" Can't connect "  r>
;

\ \s
  SocketsStartup [if] cr .(  SocketsStartup error) abort [then]
create my-ip-name
      cr  my-ip-addr cr  dup NtoA type GetHostName drop space type
      \ dup 1+ allot my-ip-name place

\s

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

--- NEW FILE: DumpWindows.f ---
\    File: DumpWindows.f
\  Author: Dirk Busch
\ Created: May 29th, 2003 - 11:37 - dbu
\ Updated: January 24th, 2004 - 9:06 - dbu
\
\ This is an example of how to use a callback's in Win32Forth.
\ It dump's all Top-Level-Windows to the console.

anew DumpWindows.f

INTERNAL

[UNDEFINED] zCount [if]
: zCount        ( a1 -- a2 len ) \ get length of zstring
    TRUE 2dup 0 scan nip - ;
[then]

: GetProcessId  { hWnd -- ProcessID } \ get ProcessId for given window
        here rel>abs hWnd call GetWindowThreadProcessId drop here @ ;

: GetThreadId   { hWnd -- ThreadID } \ get ThreadId for given window
        0 hWnd call GetWindowThreadProcessId ;

\ Define the callback function for EnumWindows().
\
\ CallBack: Need's the NUMBER OF PARAMTERS passed to the funtion by
\           Windows on TOS
\
\ CallBack: Creates TWO definitions!  The first has the name you specify,
\           and the second has the same name, prefixed with a '&' meaning
\           'address of' This second definition is the one which returns the
\           address of the callback, and must be passed to Windows.

2 CallBack: DumpWindowCallback { hWnd lParam \ buff$ -- int } \ callback function for EnumWindows
        LMAXCOUNTED localalloc: buff$

        cr
        hWnd h.8 space
        hWnd GetProcessId h.8 space
        hWnd GetThreadId h.8 space

        LMAXCOUNTED buff$ rel>abs  hWnd
        call GetClassName 0<> if buff$ zcount type then cr 27 spaces

        LMAXCOUNTED buff$ rel>abs  hWnd
        call GetWindowText 0<> if buff$ zcount type else ." <no title>" then

        true ; \ default return value

: (.Windows)    ( -- ) \ dump all Top-Level-Windows to the console
        0                  \ lParam is passed to the callback funtion by Windows
        &DumpWindowCallback rel>abs \ get address of the callback function
        Call EnumWindows drop ;     \ and use it

EXTERNAL

: .Windows      ( -- ) \ dump all Top-Level-Windows to the console
        cr cr ." Top-Level-Windows:"
        cr ." hWnd     ProcId   ThreadId ClassName - WindowTitle"
        (.Windows) cr ;

MODULE

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

--- NEW FILE: tetris.f ---
\ tt.pfe        Tetris for terminals, redone in ANSI-Forth.
\               Written 05Apr94 by Dirk Uwe Zoller,
\                       e-mail du...@ro....
\               Look&feel stolen from Mike Taylor's "TETRIS FOR TERMINALS"
\
\               Please copy and share this program, modify it for your system
\               and improve it as you like. But don't remove this notice.
\
\               Thank you.

\               - Changed for Win32Forth
\                 Sonntag, März 14 2004 by Dirk Busch (dbu)
\               - Changed to display the next piece
\                 Samstag, März 20 2004 by Dirk Busch (dbu)

only forth also definitions

true value create-turnkey? \ set to false when you don't want a turnkey app

[defined] forget-tt [if] forget-tt [then] marker forget-tt
[defined] extensions [if] extensions also [then]

vocabulary tetris  tetris also definitions

decimal

\ Variables, constants

bl bl 2constant empty           \ an empty position
variable wiping                 \ if true: wipe brick, else draw brick
 2 constant col0                \ position of the pit
 0 constant row0

10 constant wide                \ size of pit in brick positions
20 constant deep

0x20004 value left-key          \ customize if you don't like them
0x20006 value rot-key           \ currently this values are for the
0x20005 value right-key         \ arrow key's in Win32Forth
0x20007 value drop-key

char P  value pause-key
12      value refresh-key
char Q  value quit-key

variable score
variable pieces
variable levels
variable delay

variable brow                   \ where the brick is
variable bcol

\ stupid random number generator

variable seed

: randomize     time&date + + + + + seed ! ;

1 cells 4 = [IF]
0x10450405 Constant generator

: rnd  ( -- n )  seed @ generator um* drop 1+ dup seed ! ;

: random ( n -- 0..n-1 )  rnd um* nip ;
[ELSE]
: random        \ max --- n ; return random number < max
                seed @ 13 * [ hex ] 07FFF [ decimal ] and
                dup seed !  swap mod ;
[THEN]

\ Access pairs of characters in memory:

: 2c@           dup 1+ c@ swap c@ ;
: 2c!           dup >r c! r> 1+ c! ;

: d<>           d= 0= ;

\ Drawing primitives:

: 2emit         emit emit ;

: position      \ row col --- ; cursor to the position in the pit
                2* col0 + swap row0 + at-xy ;

: stone         \ c1 c2 --- ; draw or undraw these two characters
                wiping @ if  2drop 2 spaces  else  2emit  then ;

\ Define the pit where bricks fall into:

: def-pit       create  wide deep * 2* allot
                does>   rot wide * rot + 2* + ;

def-pit pit

: empty-pit     deep 0 do wide 0 do  empty j i pit 2c!
                loop loop ;

\ Displaying:

: draw-bottom   \ --- ; redraw the bottom of the pit
                deep -1 position
                [char] + dup stone
                wide 0 do  [char] = dup stone  loop
                [char] + dup stone ;

: draw-frame    \ --- ; draw the border of the pit
                deep 0 do
                    i -1   position [char] | dup stone
                    i wide position [char] | dup stone
                loop  draw-bottom ;

: bottom-msg    \ addr cnt --- ; output a message in the bottom of the pit
                deep over 2/ wide swap - 2/ position type ;

: draw-line     \ line ---
                dup 0 position  wide 0 do  dup i pit 2c@ 2emit  loop  drop ;

: draw-pit      \ --- ; draw the contents of the pit
                deep 0 do  i draw-line  loop ;

: show-key      \ char --- ; visualization of that character
                dup bl <
                if  [char] @ or  [char] ^ emit  emit  space
                else  [char] ` emit  emit  [char] ' emit
                then ;

: show-help     \ --- ; display some explanations
                30  1 at-xy ." ***** T E T R I S *****"
                30  2 at-xy ." ======================="
                30  4 at-xy ." Use keys:"
                32  5 at-xy ." 'arrow left'  Move left"
                32  6 at-xy ." 'arrow right' Move right"
                32  7 at-xy ." 'arrow up'    Rotate"
                32  8 at-xy ." 'arrow down'  Drop"
                32  9 at-xy pause-key   show-key ."  Pause"
                32 10 at-xy refresh-key show-key ."  Refresh"
                32 11 at-xy quit-key    show-key ."  Quit"
                30 16 at-xy ." Score:              Next piece:"
                30 17 at-xy ." Pieces:"
                30 18 at-xy ." Levels:"
                 0 22 at-xy ."  ==== This program was written 1994 in pure dpANS Forth by Dirk Uwe Zoller ===="
                 0 23 at-xy ."  ==================== Win32Forth port 2004 by Dirk Busch ======================" ;

: update-score  \ --- ; display current score
                38 16 at-xy score @ 3 .r
                38 17 at-xy pieces @ 3 .r
                38 18 at-xy levels @ 3 .r ;

: refresh       \ --- ; redraw everything on screen
                page draw-frame draw-pit show-help update-score ;

\ Define shapes of bricks:

: def-brick     create  4 0 do
                            ' execute  0 do  dup i chars + c@ c,  loop drop
                            refill drop
                        loop
                does>   rot 4 * rot + 2* + ;

def-brick brick1        s"         "
                        s" ######  "
                        s"   ##    "
                        s"         "

def-brick brick2        s"         "
                        s" <><><><>"
                        s"         "
                        s"         "

def-brick brick3        s"         "
                        s"   {}{}{}"
                        s"   {}    "
                        s"         "

def-brick brick4        s"         "
                        s" ()()()  "
                        s"     ()  "
                        s"         "

def-brick brick5        s"         "
                        s"   [][]  "
                        s"   [][]  "
                        s"         "

def-brick brick6        s"         "
                        s" @@@@    "
                        s"   @@@@  "
                        s"         "

def-brick brick7        s"         "
                        s"   %%%%  "
                        s" %%%%    "
                        s"         "

\ this brick is actually in use:
def-brick brick         s"         "
                        s"         "
                        s"         "
                        s"         "

\ this brick will come next:
def-brick next-brick    s"         "
                        s"         "
                        s"         "
                        s"         "

def-brick scratch       s"         "
                        s"         "
                        s"         "
                        s"         "

create bricks   ' brick1 ,  ' brick2 ,  ' brick3 ,  ' brick4 ,
                ' brick5 ,  ' brick6 ,  ' brick7 ,

create brick-val 1 c, 2 c, 3 c, 3 c, 4 c, 5 c, 5 c,

variable brick-value

: is-next-brick \ brick --- ; activate a shape of brick
                >body ['] next-brick >body 32 cmove ;

: get-next-brick \ --- ; select the next brick by random
                1 pieces +!  7 random
                bricks over cells + @ is-next-brick
                brick-val swap chars + c@ brick-value ! ;

: is-brick      \ brick --- ; activate a shape of brick
                >body ['] brick >body 32 cmove ;

: new-brick     \ --- ; select brick, count it
                ['] next-brick is-brick brick-value @ score +!
                get-next-brick ;

: rotleft       4 0 do 4 0 do
                    j i brick 2c@  3 i - j scratch 2c!
                loop loop
                ['] scratch is-brick ;

: rotright      4 0 do 4 0 do
                    j i brick 2c@  i 3 j - scratch 2c!
                loop loop
                ['] scratch is-brick ;

: draw-brick    \ row col
                4 0 do 4 0 do
                    j i brick 2c@  empty d<>
                    if  over j + over i +  position
                        j i brick 2c@  stone
                    then
                loop loop 2drop ;

: show-brick    wiping off draw-brick ;
: hide-brick    wiping on  draw-brick ;

: draw-next-brick \ row col ---
                4 0 do 4 0 do
                    j i next-brick 2c@  empty d<>
                    if  over j + over i +  position
                        j i next-brick 2c@  stone
                    then
                loop loop 2drop ;

: show-next-brick    wiping off draw-next-brick ;
: hide-next-brick    wiping on  draw-next-brick ;

: put-brick     \ row col --- ; put the brick into the pit
                4 0 do 4 0 do
                    j i brick 2c@  empty d<>
                    if  over j +  over i +  pit
                        j i brick 2c@  rot 2c!
                    then
                loop loop  2drop ;

: remove-brick  \ row col --- ; remove the brick from that position
                4 0 do 4 0 do
                    j i brick 2c@  empty d<>
                    if  over j + over i + pit empty rot 2c!  then
                loop loop  2drop ;

: test-brick    \ row col --- flag ; could the brick be there?
                4 0 do 4 0 do
                    j i brick 2c@ empty d<>
                    if  over j +  over i +
                        over dup 0< swap deep >= or
                        over dup 0< swap wide >= or
                        2swap pit 2c@  empty d<>
                        or or if  unloop unloop 2drop false  exit  then
                    then
                loop loop  2drop true ;

: move-brick    \ rows cols --- flag ; try to move the brick
                brow @ bcol @ remove-brick
                swap brow @ + swap bcol @ + 2dup test-brick
                if  brow @ bcol @ hide-brick
                    2dup bcol ! brow !  2dup show-brick put-brick  true
                else  2drop brow @ bcol @ put-brick  false
                then ;

: rotate-brick  \ flag --- flag ; left/right, success
                brow @ bcol @ remove-brick
                dup if  rotright  else  rotleft  then
                brow @ bcol @ test-brick
                over if  rotleft  else  rotright  then
                if  brow @ bcol @ hide-brick
                    if  rotright  else  rotleft  then
                    brow @ bcol @ put-brick
                    brow @ bcol @ show-brick  true
                else  drop false  then ;

: insert-brick  \ row col --- flag ; introduce a new brick
                2dup test-brick
                if  2dup bcol ! brow !
                    2dup put-brick  draw-brick  true
                else  false  then ;

: drop-brick    \ --- ; move brick down fast
                begin  1 0 move-brick 0=  until ;

: move-line     \ from to ---
                over 0 pit  over 0 pit  wide 2*  cmove  draw-line
                dup 0 pit  wide 2*  blank  draw-line ;

: line-full     \ line-no --- flag
                true  wide 0
                do  over i pit 2c@ empty d=
                    if  drop false  leave  then
                loop nip ;

: remove-lines  \ ---
                deep deep
                begin
                    swap
                    begin  1- dup 0< if  2drop exit  then  dup line-full
                    while  1 levels +!  10 score +!  repeat
                    swap 1-
                    2dup <> if  2dup move-line  then
                again ;

: to-upper      \ char --- char ; convert to upper case
                dup [char] a >= over [char] z <= and if  bl -  then ;

: interaction   \ --- flag
                case  key to-upper
                    left-key    of  0 -1 move-brick drop  endof
                    right-key   of  0  1 move-brick drop  endof
                    rot-key     of  0 rotate-brick drop  endof
                    drop-key    of  drop-brick  endof
                    pause-key   of  S"  paused " bottom-msg  key drop
                                    draw-bottom  endof
                    refresh-key of  refresh  endof
                    quit-key    of  false exit  endof
                endcase  true ;

: initialize    \ --- ; prepare for playing
                randomize empty-pit refresh
                0 score !  0 pieces !  0 levels !  100 delay !
                get-next-brick ;

: adjust-delay  \ --- ; make it faster with increasing score
                levels @
                dup  50 < if  100 over -  else
                dup 100 < if   62 over 4 / -  else
                dup 500 < if   31 over 16 / -  else  0  then then then
                delay !  drop ;

: play-game     \ --- ; play one tetris game
                begin
                    15 30 hide-next-brick
                    new-brick
                    15 30 show-next-brick

                    -1 3 insert-brick
                while
                    begin  4 0
                        do  35 13 at-xy
                            delay @ ms key?
                            if interaction 0=
                                if  unloop exit  then
                            then
                        loop
                        1 0 move-brick  0=
                    until
                    remove-lines
                    update-score
                    adjust-delay
                repeat ;

forth definitions

: tt            \ --- ; play the tetris game
                initialize
                s"  Press any key " bottom-msg key drop draw-bottom
                begin
                    play-game
                    s"  Again? " bottom-msg key to-upper [char] Y =
                while  initialize  repeat
                create-turnkey?
                if   bye \ quit our turnkey application
                else 0 23 at-xy cr
                then ;

\ create a turnkey application
create-turnkey? [IF]

: set-console-title ( -- )
         Z" Tetris" CONHNDL call SetWindowText drop ;

: tetris-hello ( -- )  \ startup stuff

        \ default initialization (needed for all turnkey apps)
        init-console
        if initialization-chain do-chain then
        exception@ if bye then

        \ our own initialization
        MENU-OFF              \ close menubar
        set-console-title     \ set window title
        INIT-SCREEN           \ show console

        get-commandline       \ copy commandline to SOURCE
        default-application ; \ and run our app

\ override init-console with the default
\ to make shure that we have no statusbar in the turnkey app.
\ ' x_init-console is init-console (this is done in the kernel now)

\ override default-hello with our own one
' tetris-hello is default-hello

\ and create the turnkey app.
&appdir OFF \ create the exe-file in the current folder
' tt turnkey tetris
5 pause-seconds bye

[else]

TT

only forth also definitions

[then]

--- NEW FILE: color.f ---
0 [IF]

   Forth to HTML converter

   Main contributors:
      Brad Eckert       br...@SP...
      Ed Beroset      ber...@SP...
      Dirk Busch         di...@SP...

   Revision 7b. See bottom for revision history.

   This ANS Forth program is public domain. It translates ANS Forth to colorized
   HTML. Hyperlinks to the ANS Forth draft standard are inserted for all ANS
   standard words. Hyperlinks to user definitions are included.

   Usage: HTML FileName    Generates HTML file from Forth source.
                           Output file is Filename with .HTM extension.
          Q [forth code]   Outputs HTML for 1 line to screen

[...1022 lines suppressed...]
\ 5.  (BNE) Added multiline { comment. Replaced -1 WORD with [CHAR] |.
\     Put hyperlinks that should not be overridden in a separate wordlist.
\ 5a. (DBU) - Merged Rev 5 with 4d
\           - Changed { to work as a multicoment and for locals.
\           - Changed multicomment to color the terminator of the comments (( ))
\           - and comment: comment; { } too.
\           - Renamed col ,$ and header because they are used in Win32Forth
\           - Added sys-warning-off & sys-warning-on to avoid "****System word:
\             <abc> used in: <xyz> at file..." messages when using Win32Forth.
\ 6.  (BNE) Limited text to 80 columns, cleaned up comments a bit. Added option
\     for different color schemes.
\ 6a. (DBU) - Merged Rev 6 with 5a
\           - Minimized color changes in HTML output for comments.
\ 7.  (BNE) - Added some of Dirk's changes
\ 7a. (DBU) - Merged Rev 7 with 6a
\           - Added more words used in Win32Forth.
\           - Added support for locals.
\ 7b. (BNE) - Made ALIAS a defining word.
\ 7c. (BNE) - Made ( multi-line.