\ Hextrix in J-Forth
\ Author:  Kasper Østerbye
\ Copyright 1991 Kasper Østerbye
\ Version: 1.0
\
\ This game was written to find out the workings of simple amiga
\ graphics and J-Forth in particular.
\
\ This is give-away-ware. This program is now yours! If you can convince
\ anyone that they should by it, you deserve the profit - I would be
\ interested in knowing though!
\ I am not a poor student, so please do not send 5$ (An amiga 3000
\ would be nice though), but any comments or questions are welcomed.

\ Kasper Østerbye
\ Buderupholmvej 48
\ 9530 Støvring, Denmark
\ email: kasper@iesd.auc.dk
\
\ SPECIAL WARNING FOR THE FOOLS IN USA: Extensive game play can seriously
\ hurt your hand, and you might develop tenosynovitis. There is two
\ things to say about that. 1) It is not my fault, and 2) If you need
\ treatment and cannot affort it, considder whom you give a wote next time!

\ mdh - slight mods to be compatible with new locals (v2.0+) in beta state,
\       everything still works with V2.0 and earlier.  Final v2.0+ locals
\       will be completely backward-compatible.

INCLUDE? NewWindow.Setup JU:AMIGA_GRAPH
INCLUDE? ?CLOSEBOX JU:AMIGA_EVENTS
INCLUDE? NewScreen.Setup JU:SCREEN_SUPPORT
INCLUDE? { JU:LOCALS
INCLUDE? EV.GETCLASS JU:AMIGA_EVENTS
INCLUDE? CHOOSE JU:RANDOM
INCLUDE? LOADRGB4() ju:graph_support
INCLUDE? SPRITES JI:GRAPHICS/VIEW.j
INCLUDE? SimpleSprite JI:GRAPHICS/SPRITE.j
INCLUDE? GETSPRITE() JU:SPRITES


INCLUDE? Pieces pieces.f
ANEW TASK-HEXTRIX.f      \ added '.f' -- mdh
decimal

\ ******************************************************
\  GAME CONSTANTS
\ ******************************************************


1 Constant bordercolor
13 constant borderwidth  \ should be odd to look good
23 constant borderheight





\ *****************************************************************
\      SCREEN AND WINDOW
\ *****************************************************************

\ Declare necessary Amiga 'C' structures.
NewScreen GameNewScreen
NewWindow GameNewWindow


VARIABLE Game-SCREEN

create aColorTable
hex
   000 w, ccc w, 0d0 w, fff w,
   f00 w, 0dd w, d0d w, 888 w,
   a60 w, 00f w, fd0 w, fca w,
   a60 w, 00f w, fd0 w, fca w, \ This last line is not used
   000 w, ccc w, 0d0 w, fff w, \ And all this is just the same as
   f00 w, 0dd w, d0d w, 888 w, \ the 4 lines above
   a60 w, 00f w, fd0 w, fca w,
   a60 w, 00f w, fd0 w, fca w,
decimal


: CLOSE.Game.SCREEN ( -- , CLose demo screen )
    game-screen @ closescreen()
;

: OPEN.Game.SCREEN ( -- screen | NULL )
   \ Set to default values.
     GameNewScreen NewScreen.Setup
     GameNewWindow NewWindow.Setup
   \
   \ Modify defaults for this demo.
   HIRES ( LACE | ) SPRITES | GameNewScreen ..! ns_viewmodes
   640   GameNewScreen ..! ns_width
   210   GameNewScreen ..! ns_height
     4   GameNewScreen ..! ns_depth  ( 16 colors )
     0" HexTrix by Kasper Østerbye" >abs
         GameNewScreen ..! ns_DefaultTitle

      \ Open Screen and store pointer in NewWindow structure.
   GameNewScreen openscreen() dup Game-Screen !  ( Open screen. )

      \ Sometimes the Amiga can build a bad COPPER list for screens.
      \ This can happen if you have Emacs and Workbench up in INTERLACE
      \ mode and open a NON-INTERLACE screen.
      \ The following calls will correct this problem (hopefully).
   dup
   IF  game-screen @ screentoback()
       RemakeDisplay()
       game-screen @ screentofront()
       game-screen @ .. sc_viewport aColorTable 32 loadRGB4()
   THEN

;

\ Check for proper opening.
: OPEN.Game.WINDOW  ( screen -- window | NULL )
    >abs GameNewWindow ..! nw_screen

    \ Set up window.
    CUSTOMSCREEN   GameNewWindow ..! nw_type
    VANILLAKEY CLOSEWINDOW | INTUITICKS | GameNewWindow ..! nw_idcmpflags
    0" HexTrix in JFORTH -- By Kasper Østerbye" >abs GameNewWindow ..! nw_Title
    0    GameNewWindow ..! nw_TopEdge
    600  GameNewWindow ..! nw_Width
    210  GameNewWindow ..! nw_Height
    GameNewWindow gr.opencurw
;


\ ******************************************************
\
\ sprites used for moving pieces
\
\ ******************************************************

VARIABLE usingSprites

SimpleSprite Sprite-0
SimpleSprite Sprite-1
SimpleSprite Sprite-2
SimpleSprite Sprite-3

2 CONSTANT spriteNumberOffset

: SpriteArray ( index -- spriteaddr )
   CASE
      0 OF Sprite-0 ENDOF
      1 OF Sprite-1 ENDOF
      2 OF Sprite-2 ENDOF
      3 OF Sprite-3 ENDOF
   ENDCASE
;

: OPEN.SPRITES ( --  )
   4 0
   DO
       i spriteArray i spriteNumberOffset +  ( we reserve sprites 2,3,4,5 )
         getSprite()
       -1 = ?abort" OPEN.SPRITE - Sprite could not be allocated!"
       0   i spriteArray ..! ss_x
       0   i spriteArray ..! ss_y
       7   i spriteArray ..! ss_height
   LOOP
;

\ Build sprite data, sprites are two planes deep.
2 base !   ( Use binary to see which bits are on. )
CREATE SPRITE-DATA
here
0 w,    0 w,   ( position control, used by system. )
\        Plane0                     Plane1
   0001,1111,0000,0000 W,    0001,1111,0000,0000 W,
   0011,1111,1000,0000 W,    0011,1111,1000,0000 W,
   0111,1111,1100,0000 W,    0111,1111,1100,0000 W,
   1111,1111,1110,0000 W,    1111,1111,1110,0000 W,
   0111,1111,1100,0000 W,    0111,1111,1100,0000 W,
   0011,1111,1000,0000 W,    0011,1111,1000,0000 W,
   0001,1111,0000,0000 W,    0001,1111,0000,0000 W,

      0 W,     0 W,   ( unattached simple sprite. )

here swap - constant SPRITE_DATA_SIZE
decimal

4 ARRAY Sprite-data-ptrs  ( point to ALLOCed CHIP RAM copy )

: CHANGE.SPRITES
\ Allocate CHIP memory and copy sprite to it.
\ AMIGAs with more than 512K RAM might be running
\ JForth in FAST RAM.  We could NOT, therefore, use
\ the SPRITE-DATA directly since it would be inaccessable
\ to the graphics coprocessors.
    4 0
    DO
       MEMF_CHIP sprite_data_size allocblock ?dup
       IF
          dup i sprite-data-ptrs !   ( save memory pointer )
          sprite-data swap sprite_data_size cmove ( copy )
          game-screen @ dup IF .. sc_viewport THEN
             i spriteArray  i sprite-data-ptrs @   ChangeSprite()
       ELSE
           ." Unable to allocate all sprites" abort
       THEN
    LOOP
;

: FREE.SPRITES
   4 0
   DO
      i spriteNumberOffset + freesprite()
      i sprite-data-ptrs @ freeblock
   LOOP
;

\ *********************************************************************
\ Misc stuff to go elsewhere later
\ *********************************************************************


: GVP ( --- relAddr , gameViewPort )
   game-screen @ .. sc_viewport
;

: setRGB4() (  viewPort penNr R G B )
   callvoid>abs graphics_lib setRGB4
;

: SetSpriteColors { penNr -- }  \ had to add '--' mdh
   gvp  23   penNr aColorTable ctable>rgb    setRGB4()
   gvp  27   penNr aColorTable ctable>rgb    setRGB4()
;

: MoveSprite {  x y spr# -- }  \ had to add '--' mdh
\ move sprite to screen coordinate x,y
\ take spriteNumberOffset and hires mode into account

   gvp spr# spriteArray x 2+  y moveSprite()
;

: HideSprites
   0 setSpriteColors
   4 0 do 30 30 i MoveSprite loop
;


\ ******************************************************
\
\ misc utilities
\
\ ******************************************************




: p+ { x y x' y' -- x' y' } ( add the points ) \ changed --> to -- mdh
   x x' +   \ commented out mdh   -> x'
   y y' +   \ commented out mdh   -> y'
;

: p-right { c r  -- c r } ( right-point )
   c 1+ -> c
   c 1 and IF  ELSE r 1+ -> r THEN
   c r   \ added mdh
;

: p-left { c r -- c r } ( left-point )
   c 1- -> c
   c 1 and IF r 1- -> r THEN
   c r   \ added mdh
;


: hex>rect ( c r --> c' r' )
   over 2/ -
;

: rect>hex ( c r --> c' r' )
   over 2/ +
;


\ **********************************************************
\ INTERNAL BOARD (IB)
\ **********************************************************

borderWidth borderHeight * carray ib ( Internal Board )

: clearIb
   0 ib borderWidth borderHeight * erase
;

: getIb ( c r --> byte )
   swap borderHeight * + ib c@
;

: putIb ( byte c r --> , store byte )
   swap borderHeight * + ib c!
;



: isIbEmpty? ( hex-c hex-r --> bool )
   getIb 0=
;

: .Ib
   borderHeight 0
   DO i 4 .r
      borderWidth 0
      DO
         i j getIb 2 .r
      LOOP
      cr
   LOOP
;

: initIb
   clearIb
   borderHeight 0
   DO
      borderColor 0 i putIb
      borderColor borderwidth 1- i putIb
   LOOP
   borderWidth 0
   DO
      borderColor i borderHeight 1- putIb
   LOOP
;


\ ******************************************************
\
\ Drawing primitives
\
\ ******************************************************

: draw.dotxy { col x y -- }
   col gr.color!
   x y x 21 + y gr.rect
   x 2+ y 1- over 17 + over 2 + gr.rect
   x 4 + y 2- over 13 + over 4 + gr.rect  \ 1st '4 +' was 4+  -- mdh
   x 6 + y 3 - over 9 + over 6 + gr.rect
;

: cr>xy { c r -- x y } ( convert hex col and row to screen x and y )
   c 16 *   ( x -- )
   8 r *    4 c *  -    7 +  ( x y -- )
;


: draw.dotcr  ( col c r --  , draw based on column and row )
      cr>xy  draw.dotxy
;

\ ******************************************************
\
\ OPERATIONS ON CURRENT PIECE
\
\ ******************************************************

VARIABLE NextPieceIndex
VARIABLE CurrentPieceIndex ( index of the piece <0..9> )
VARIABLE CurrentPiece ( Holds a piece address )
VARIABLE CurrentColor
VARIABLE CurrentRotation ( 0..5 )

VARIABLE CurrentCol  \ these are hexcoordinates
VARIABLE CurrentRow

: .current cr
   ." Index: " CurrentPieceIndex ? cr
   ." Color: " CurrentColor ? cr
   ." Rotat: " currentRotation ? cr
   ." Col:   " currentCol ? cr
   ." Row:   " currentRow ? cr
;

Defer eachDot  ( collumn row --- )

: doCurrentPiece
   4 0
   DO
      currentPiece @ currentRotation @ I getDcr
      currentCol @ currentRow @ p+
      eachDot
   LOOP
;

: initNextIndex
   10 choose nextPieceIndex !
;

: findNextIndex
   nextPieceIndex @ currentPieceIndex !
   10 choose nextPieceIndex !
;

: newCurrent { Index -- }
   index 2 + currentColor !
   index pieces @ currentpiece !
   0 currentrotation !
   borderWidth 2- 2/ 2 rect>hex currentrow ! currentcol !
;


: DrawCurrentPiece
\ should be recoded using <eachDot>
  4 0 DO
      CurrentColor @
      CurrentCol @ CurrentRow @
      CurrentPiece @ CurrentRotation @ I getDcr  p+
      usingSprites @
      IF cr>xy i moveSprite drop ( color)
      ELSE draw.dotcr
      THEN
  LOOP
;

: EraseCurrentPiece
   usingSprites @ NOT
   IF
      currentcolor @
      0 currentcolor ! DrawCurrentPiece
      currentcolor !
   THEN
;

: dcp drawcurrentpiece ;
: ecp erasecurrentpiece ;

: Next>Current
   nextPieceIndex @ newCurrent ( make it current for drawing)
   borderWidth 4 + 3 rect>hex currentRow ! currentCol !
   ecp
   findNextIndex
   nextPieceIndex @ newCurrent ( make it current for drawing)
   borderWidth 4 + 3 rect>hex currentRow ! currentCol !
   dcp
   currentPieceIndex @ newCurrent
;
: RotateRight
   currentrotation @ 1+
   dup 6 = IF drop 0 THEN
   currentrotation !
;

: RotateLeft
   currentrotation @ 1-
   dup -1 = IF drop 5 THEN
   currentrotation !
;

: MoveRight
   currentCol @ currentrow @
   p-right
   currentrow ! currentcol !
;

: MoveLeft
   currentCol @ currentrow @
   p-left
   currentrow ! currentcol !
;

: MoveDown
   1 currentRow +!
;

: checkDot ( bool c r -- bool )
   hex>rect isIbEmpty? AND
;

: placementPossible ( -- bool )
   TRUE
   ' checkDot is eachDot
   doCurrentPiece
;

: RotateRight?
   RotateRight
   placementPossible
   RotateLeft
;

: RotateLeft?
   RotateLeft
   placementPossible
   RotateRight
;

: MoveRight?
   MoveRight placementPossible moveLeft
;

: MoveLeft?
   MoveLeft placementPossible moveRight
;

: MoveDown?
   1 currentRow +!
   placementPossible
   -1 currentRow +!
;



VARIABLE pieceStuck

: movePieceDown
   moveDown?
   IF ecp moveDown dcp
   ELSE TRUE pieceStuck !
   THEN
;


\ ******************************************************
\
\ Scoring
\
\ ******************************************************

100 Constant pointForRow
10  Constant pointForPiece
20  Constant pointForRelease

400 Constant xScorePos
30 Constant yScorePos

VARIABLE Score
VARIABLE hiscore
VARIABLE hifile


: drawScore
   gr.color@
   0 gr.color!
   xScorePos yScorePos over 100 + over 30 + gr.rect
   1 gr.color!
   xScorePos yScorePos " Score: " gr.xytext
   score @ gr.number
   xScorePos yScorePos 15 + " High Score: " gr.xytext
   hiscore @ gr.number
   gr.color!
;

: scorePoint ( points )
   score +!
   drawScore
;

: scoreRow pointForRow scorePoint ;

: scorePiece pointForPiece scorePoint ;

: scoreRelease ( read from current to find height )
   borderHeight 0   currentRow @ hex>rect nip -
   pointForRelease *
   scorePoint
;

\ ********************  H I G H   S C O R E *****************

: openHiFile
   " hihex" $fopen hifile !
   hifile @
;

: openNewHifile
   new " hihex" $fopen hifile !
   hifile @
;

: closeHiFile
   hifile @ ?dup
   IF fclose THEN
;

: getHiscore
   openHifile
   IF
      hifile @ hiscore 4 fread drop
      closeHiFile
   ELSE
      0 hiscore !
   THEN
;

: putHiScore
   openHiFile
   IF
      hifile @ hiscore 4 fwrite drop
      closeHifile
   ELSE \ First time there is no file
      openNewHiFile
      IF
         hifile @ hiscore 4 fwrite drop
         closeHifile
      THEN
      \ In case it did not work just forget about it
   THEN
;

: checkForHiScore
  getHiScore
  score @ hiscore @ >
  IF score @ hiscore ! putHiScore THEN
;




\ **********************************************************
\                Drawing the boarder
\ **********************************************************

: drawIb
   borderHeight 0
   DO
      borderWidth 0
      DO
         i j getIb i j rect>hex draw.dotcr
      LOOP
   LOOP
;


\ **********************************************************
\                   Eventhandling
\ **********************************************************

VARIABLE time-to-stop
VARIABLE delay 5 delay !
VARIABLE countDown delay @ countDown !
VARIABLE pausing 1 pausing !

: adjustDelay
   100,000 score @ - 20,000 / delay !
   delay @ 0 < IF 0 delay ! THEN
;


: quit-game
   free.sprites
   gr.closecurw
   close.game.screen
   quit
;

\ NOTICE: If you change any key bindings, make sure to change the
\         help text!

: do-pause-key
   case
      ascii s OF true time-to-stop ! ENDOF
      ascii p OF 1 pausing @ - pausing ! ENDOF
      ascii q OF quit-game ENDOF
      ." Press p to resume game " cr
   endcase
;

: do-key
   pausing @ 0=
   IF
        case
           ascii 8 OF rotateleft?  IF ecp rotateleft dcp  THEN    ENDOF
           ascii 5 OF rotateright? IF ecp rotateRight dcp THEN    ENDOF
           ascii 4 OF moveleft?    IF ecp moveLeft dcp    THEN    ENDOF
           ascii 6 OF moveright?   IF ecp moveRight dcp   THEN    ENDOF
           32      OF  scoreRelease
                       BEGIN movePieceDown pieceStuck @ UNTIL
                   ENDOF
           ascii s OF true time-to-stop ! ENDOF
           ascii p OF 1 pausing @ - pausing ! ENDOF
           ascii q OF quit-game ENDOF
           ." Unbound Key!?" cr
        endcase
   ELSE
      do-pause-key
   THEN
;



: doTick
   pausing @ 0=
   IF
      countDown @ 0 >
      IF
         -1 countDown +!
      ELSE
         delay @ countDown !
         movePieceDown
      THEN
   THEN
;

: handleEvent ( evclass -- )
   CASE
      0             OF ." Oh NO"  ENDOF

      CLOSEWINDOW   OF quit-game ENDOF

      VANILLAKEY    OF ev-last-code @ do-key ENDOF

      INTUITICKS    OF doTick ENDOF

      ." SHOULD NOT" dup . cr
   ENDCASE
;

: handleMovingEvents
   BEGIN
      time-to-stop @ not pieceStuck @ not and
   WHILE
      gr-curwindow @ ev.wait
      gr-curwindow @ ev.getclass handleEvent
   REPEAT
;

: tme
   FALSE time-to-stop !
   BEGIN
      handleMovingEvents
      time-to-stop @
   UNTIL
;

\ **********************************************************
\
\ **********************************************************
: dot>ib { c r -- }
   currentColor @ c r hex>rect putIb
;

: storePiece
   ' dot>ib is eachDot
   doCurrentPiece
;


: moveColDown { c l -- }
   l 1- -> l
   BEGIN
      l -1 >
   WHILE
      \ Only move dot if it needs changing ( optimization )
      \ that is, if two dots above each other is the same
      \ there is no reason to redraw...
      c l getIb c l 1+ getIb = NOT
      IF
         c l getIb dup
         c l 1+ rect>hex draw.dotcr
         c l 1+ putIb
      THEN
      l 1- -> l
   REPEAT
   0 c 0 putIb
;

: downAllDots ( l )
   borderWidth 1- 1
   DO
      I over MoveColDown
   LOOP DROP
;

: fullLine? { l -- bool }
   TRUE
   borderWidth 1
   DO
     i l isIbEmpty?
     IF drop FALSE leave THEN
   LOOP
;

: eraseLines
   borderHeight 2-
   BEGIN
      dup 1 >
   WHILE ( lineNr -- ,
      dup fullLine?
      IF dup downAllDots scoreRow
      ELSE 1- ( only subtract in case this line was not full)
      THEN
   REPEAT
   DROP
;


: playCurrentPiece
   adjustDelay
   placementPossible dup not time-to-stop !
   IF scorePiece
      FALSE pieceStuck !
      BEGIN
        handleMovingEvents
        pieceStuck @ time-to-stop @ or
      UNTIL
      FALSE usingSprites ! dcp  ( tegn rigtigt )
      HideSprites
      storePiece
      eraseLines
   THEN
;


\ **********************************************************
\ MISC testing routines, and temporary stuff
\ **********************************************************
xScorePos 150 - CONSTANT xTextPos
yScorePos 50  + CONSTANT yTextPos

: draw.help
   xTextPos yTextPos 00  +  " S     - Start new game" gr.xytext
   xTextPos yTextPos 15  +  " Q     - Quits game" gr.xytext
   xTextPos yTextPos 30  +  " P     - Toggels PAUSE"  gr.xytext
   xTextPos yTextPos 45  +  " Space - Release Piece"  gr.xytext
   xTextPos yTextPos 60  +  " 4     - Move Left"  gr.xytext
   xTextPos yTextPos 75  +  " 6     - Move Right"  gr.xytext
   xTextPos yTextPos 90  +  " 8     - Rotate Left"  gr.xytext
   xTextPos yTextPos 105 +  " 5     - Rotate Right"  gr.xytext
;

: t-open
  init-pieces
  findNextIndex
  gr.init
  open.Game.screen ?dup
  IF  open.Game.window 0=
     IF close.game.screen quit THEN
  ELSE
     quit
  THEN
  getHiScore
  open.sprites
  change.sprites
  FALSE usingSprites !
;

: t-close
   free.sprites
   gr.closecurw
   close.game.screen
;



: one-game
      gr.clear
      0 score ! drawScore
      draw.help
      initIb drawIb
      initNextIndex
      ev.flush
      1 pausing !
      BEGIN
         next>current
         currentColor @ setSpriteColors
         TRUE usingSprites ! dcp
         playCurrentPiece
         time-to-stop @
      UNTIL
      checkForHiscore
;

: hextrix (  )
   t-open
   BEGIN
      one-game
      FALSE
   UNTIL
;



." Enter:    hextrix for a game " cr  \ was 'hextris'  -- mdh


