Chip 2001 Mobile/Chip_Mobile_2001.iso/palm/spiele/quintom/quintom.exe/Quint150.txt

Text File | 1999-07-15 | 9.6 KB | 552 lines

\ Quintominoes v1.50
\ ERS 15JULY1999
needs graphics
needs Events
needs toolkit
needs case
needs resources
needs ids

decimal

here constant prefs
\ Begin of data area to be saved in Prefs

\ Now defining the pieces
\ and their initial locations
: pentos ( n --- 10*n )    \ offset of a piece-cell
5 cells * ;

create q-all 12 pentos  allot
: q-all-f
q-all
2 8 * over ! 1 cells +
1 8 * over ! 1 cells +
[ 2 base ! ]
0 over c! 1+
0 over c! 1+
11111 over c! 1+
0 over c! 1+
0 over ! 1 cells +
[ decimal ]

5 8 * over ! 1 cells +
1 8 * over ! 1 cells +
[ 2 base ! ]
0 over c! 1+
01000 over c! 1+
01111 over c! 1+
0 over c! 1+
0 over ! 1 cells +
[ decimal ]

8 8 * over ! 1 cells +
1 8 * over ! 1 cells +
[ 2 base ! ]
0 over c! 1+
00100 over c! 1+
01111 over c! 1+
0 over c! 1+
0 over ! 1 cells +
[ decimal ]

12 8 * over ! 1 cells +
1 8 * over ! 1 cells +
[ 2 base ! ]
0 over c! 1+
01100 over c! 1+
00111 over c! 1+
0 over c! 1+
0 over ! 1 cells +
[ decimal ]

2 8 * over ! 1 cells +
6 8 * over ! 1 cells +
[ 2 base ! ]
0 over c! 1+
01100 over c! 1+
01110 over c! 1+
0 over c! 1+
0 over ! 1 cells +
[ decimal ]

6 8 * over ! 1 cells +
6 8 * over ! 1 cells +
[ 2 base ! ]
0 over c! 1+
01010 over c! 1+
01110 over c! 1+
0 over c! 1+
0 over ! 1 cells +
[ decimal ]

11 8 * over ! 1 cells +
6 8 * over ! 1 cells +
[ 2 base ! ]
0 over c! 1+
00010  over c! 1+
00010 over c! 1+
01110 over c! 1+
0 over ! 1 cells +
[ decimal ]

6 8 * over ! 1 cells +
11 8 * over ! 1 cells +
[ 2 base ! ]
0 over c! 1+
00100 over c! 1+
00100 over c! 1+
01110 over c! 1+
0 over ! 1 cells +
[ decimal ]

11 8 * over ! 1 cells +
11 8 * over ! 1 cells +
[ 2 base ! ]
0 over c! 1+
00100 over c! 1+
00110 over c! 1+
01100 over c! 1+
0 over ! 1 cells +
[ decimal ]

2 8 * over ! 1 cells +
15 8 * over ! 1 cells +
[ 2 base ! ]
0 over c! 1+
00110 over c! 1+
00100 over c! 1+
01100 over c! 1+
0 over ! 1 cells +
[ decimal ]

6 8 * over ! 1 cells +
15 8 * over ! 1 cells +
[ 2 base ! ]
0 over c! 1+
00100 over c! 1+
01110 over c! 1+
00100 over c! 1+
0 over ! 1 cells +
[ decimal ]

12 8 * over ! 1 cells +
15 8 * over ! 1 cells +
[ 2 base ! ]
0 over c! 1+
01000 over c! 1+
01100 over c! 1+
00110 over c! 1+
0 swap ! ;
decimal

variable act
\ status variable, selected piece

here prefs - constant prefsize
\ End of data for Prefs

create q13 1 pentos allot
\ Swap/Scrap area

variable tg
\ Auxilliary variable

10 130 2constant FormBounds


: q-unc ( y x --- )
>r >r 8 8 r>  r>
erase-rectangle ;
: q-c ( y x --- )
>r >r 8 8 r> r>
rectangle ;
: q-l ( y x --- )
2dup swap 7 + swap line ;
: q-r  ( y x --- )
7 + q-l ;
: q-t ( y x --- )
2dup 7 + line ;
: q-b  ( y x --- )
swap 7 + swap q-t ;
\ Assorted drawing routines,
\ Blocks for selected piece,
\ Borderlines for others. All ( y x --- )


: thisbit? ( addr col row --- bool )
rot 2 cells + +  c@ swap rshift 1 and
;
: upperbit? ( addr col row --- bool )
?dup if 1 - thisbit? else 2drop 0 then
;
: lowerbit? ( addr col row --- bool )
dup 4 < if 1 + thisbit? else 2drop drop 0 then
;
: rightbit? ( addr col row --- bool )
swap ?dup if 1 - swap thisbit? else 2drop 0 then
;
: leftbit? ( addr col row --- bool )
swap dup 4 < if 1 + swap thisbit? else 2drop drop 0 then
;
\ Test for blocks and relative
\ positions in pieces, needed for
\ proper drawing


: scr-pos-p1 ( addr row --- addr row absy xbasepos )
over  @ over 8 * + 2 pick 1 cells +  @
;

: scr-pos-p2 ( absy xbasepos relx --- absy absx yboundsflag )
8 * + over FormBounds within
;
\ absolute screen positioning, parts one and two

: q-unblock ( addr row --- )
5 0 do over over i  swap thisbit?
 if
 scr-pos-p1 i scr-pos-p2 if q-unc else 2drop then
then
loop
2drop
;
\ undraws a row of given piece

: q-block ( addr row --- )
tg @ if
5 0 do over over i  swap thisbit?
 if
 scr-pos-p1 i scr-pos-p2 if q-c else 2drop then
then
loop

else
5 0 do over over i  swap thisbit?
if

 over over i  swap rightbit? 0= if
 scr-pos-p1 i scr-pos-p2 if q-l else 2drop then
 then

 over over i  swap leftbit? 0= if
 scr-pos-p1 i scr-pos-p2 if q-r else 2drop then
 then

 over over i  swap upperbit? 0= if
 scr-pos-p1 i scr-pos-p2 if q-t else 2drop then
 then

 over over i  swap lowerbit? 0= if
 scr-pos-p1 i scr-pos-p2 if q-b else 2drop then
 then

then
loop

then
2drop
;
\ Draws each row of each given piece

 : q-undraw ( n --- )
   dup if
  1 - q-all swap pentos +
  5 0 do dup i
  q-unblock
  loop
then
drop
;
\ Entry to undraw a piece, calls row undraw
\ routine

 : q-draw ( addr --- )
  5 0 do dup i
  q-block
  loop
  drop
;
\ Entry to draw a piece, calls row draw
\ routine


: q-col ( val i --- )
swap
5 0 do dup i rshift 1 and
2 pick
 lshift q13 8 + i - dup >r
c@ or r>  c!
loop
2drop
;
\ column handler for rotating
\ a piece


: q-rot ( addr --- )
q13 9 0 do dup i + 0 swap c! Loop drop
2 cells + 5 0 do dup
i +   c@ i q-col
loop
5 0 do dup q13 2 cells + i + c@ swap c!
1+
 loop
drop
;
\ entry for piece rotation, calls
\ column handler

: q-flip ( addr --- )
q13 9 0 do dup i + 0 swap c! Loop drop 2 cells +
5 0 do dup i  +  c@ q13 8 + i -
c! Loop
5 0 do dup q13 2 cells + i + c@ swap c!
1+
loop
 drop
;
\ routine to flip a piece

: q-paint-all ( --- )

12 0 do i 1+ act @ = if
1 tg ! Else 0 tg ! then
q-all i pentos +
q-draw
loop
;
\ name says it


: q-rt ( --- )
q-all act @ dup q-undraw 1 - pentos +
q-rot ;

: q-flp ( --- )
q-all act @ dup q-undraw 1 - pentos +
q-flip ;

: q-left ( --- )
q-all act @ dup q-undraw 1 - pentos +  1 cells + dup
@ 8 - swap !
;

: q-right ( --- )
q-all act @ dup q-undraw 1 - pentos +  1 cells + dup
@ 8 + swap !
;

: q-up ( --- )
q-all act @ dup q-undraw 1 - pentos +  dup
@ 8 - swap !
;
: q-down ( --- )
q-all act @ dup q-undraw 1 - pentos +  dup
@ 8 + swap !
;
\ ... how to move them pieces



3000 constant AboutBox
3001 constant HelpString

2001 constant AboutMenuItem
2002 constant HelpMenuItem
2003 constant RestartMenuItem
2004 constant DeslctMenuItem
2005 constant RefreshMenuItem

516 constant CalendarKey
517 constant AddressKey
518 constant ToDoKey
519 constant MemoKey
11 constant UpKey
12 constant DownKey

266 constant SilkFindKey
\ 261 constant SilkMenuKey

1001 constant FlipButton
1002 constant LeftButton
1005 constant RightButton
1006 constant RotButton
1004 constant UpButton
1003 constant DownButton

50. 2constant timeout.


variable match
variable yp
variable xp

variable ym
variable xm

: q-move ( --- )
match @ if
ym @ 8 / yp @ 8 / 2dup > if
  q-down 8 yp +!
then < if
 q-up -8 yp +! then
xm @ 8 / xp @ 8 / 2dup > if
 q-right 8 xp +!
then < if
 q-left -8 xp +! then
q-paint-all
then
;

: q-match ( y x --- )
 xp @ swap dup 8 + within swap
 yp @ swap dup 8 + within and if 1 match ! then
;

: q-find ( addr row --- )
5 0 do over over i  swap thisbit?
 if
 over  @ over 8 * + 2 pick 1 cells +  @ i 8 * + q-match
then
loop
2drop
;

: q-select (  --- )

q-all
12 0 do dup i pentos +
5 0 do dup i q-find
loop drop
match @ if act @ q-undraw i 1 + act !
q-paint-all
leave
then
loop drop
;


variable hard

: do-it  ( --- )
case
MenuEvent of
event >abs itemid case
AboutMenuItem of
      AboutBox FrmAlert drop
      endof
HelpMenuItem of
      HelpString FrmHelp
      endof
RestartMenuItem of
      q-all-f 1000 showform q-paint-all
      endof
DeslctMenuItem of
       act @ q-undraw
      0 act ! 1000 showform
      q-paint-all
      endof
RefreshMenuItem of
       1000 showform q-paint-all
      endof
endcase
endof
KeyDownEvent of
 event >abs itemid
 case
 CalendarKey of act @ if q-flp then q-paint-all 1 hard ! endof
 AddressKey  of act @ if q-left then q-paint-all 1 hard ! endof
 ToDoKey     of act @ if q-right then q-paint-all 1 hard ! endof
 MemoKey     of act @ if q-rt then q-paint-all 1 hard ! endof
 UpKey       of act @ if q-up q-paint-all then 1 hard !  endof
 DownKey     of act @ if q-down q-paint-all then 1 hard !  endof
 SilkFindKey of 1 hard ! endof
endcase

endof

CtlSelectEvent of
 event >abs itemid
 case
 FlipButton   of act @ if q-flp q-paint-all then endof
 LeftButton   of act @ if q-left q-paint-all then endof
 RightButton  of act @ if q-right q-paint-all then endof
 RotButton    of act @ if q-rt q-paint-all then endof
 UpButton     of act @ if q-up q-paint-all then endof
 DownButton   of act @ if q-down q-paint-all then endof
 endcase

endof

PenDownEvent of
0 match !
coords@ xp ! yp ! q-select
endof

PenMoveEvent of
coords@ xm ! ym ! q-move
endof


endcase
;
\ Main event handling



\ The next two words were taken
\ from the Quartus discussion forum...
(id) QES2 2constant crid
: get-stored ( -- bool )
  prefsize  prefs >abs  1 crid
  PrefGetAppPreferencesV10 ;

: set-stored ( --- )
  prefsize  prefs >abs  1 crid
  PrefSetAppPreferencesV10 ;


: q-init ( --- )
get-stored 0 = if
1 act !  0 tg ! 0 hard !
Q-all-f
 then
1000 showform
q-paint-all
;
\ Initialize things

: go ( --- )
decimal
q-init
begin
begin timeout. event >abs EvtGetEvent event @ ?dup until
 do-it
hard @ 0= if
 HandleEvent then
0 hard !
again ;
\ Main event loop

-257 constant byeThrow

: shand ( --- )
  ['] go catch
  \ If the application is exiting,
  \  store settings:
  dup byeThrow
 = if
set-stored then
  throw ;
\ "Standard" exit handler

(id) QES2  (id) rsrc
use-resources
\ ...also if you want to run it in the
\ Quartus environment


cr
.s