USING: accessors arrays assocs kernel math math.vectors ranges
math.functions sequences vectors combinators math.order classes
classes.tuple strings serialize
   juere-engine.utils ;
IN: juere-engine.stage

TUPLE: stage
   tiles attributes entities objects actions
   camera-xyz camera-pitch camera-yaw ; ! particles sounds

: blank-stage ( -- stage )
   V{ } V{ } V{ } V{ } V{ }
   { 0 8 8 } 30 150 
   stage boa ;

! == Tile and Tile Material Management

TUPLE: tile 
   height material attributes ;

TUPLE: material
   side-tex top-tex ;

: <default-mat> ( -- material )
   "stonesides.bmp" "stonetile.bmp" [ <rsrc> ] bi@
   material boa ;

: <mat> ( path path -- material )
   [ <rsrc> ] bi@ material boa ;

: <tile> ( height -- tile )
   <default-mat> V{ } tile boa ;

: <tiles> ( size exemplar -- tiles )
   [ 1 - dup [ [0..b] ] bi@ ] dip
         '[ 2array _ 2array ]
   cartesian-map concat >vector ;
: blank-tiles ( size -- tiles ) 0 <tile> <tiles> ;

: (with-tile) ( tiles x y quot -- tiles )
   [ 2array ] dip swapd [ ?change-at ] keepd ; inline
: with-tile ( stage x y quot -- stage )
   [ (with-tile) ] 3curry change-tiles ; inline

: shift-tiles ( tiles vector -- tiles )
   '[ [ _ v+ ] dip ] assoc-map ;

: shift-stage ( stage vector -- tiles ) 
   [ shift-tiles ] change-tiles ;

: ramped-tiles ( size -- tiles ) 
   [ blank-tiles [ drop dup sum 0.05 max <tile> ] assoc-map ] 
   keep -2 / ceiling dup 2array shift-tiles ;

! == Entities

TUPLE: entity
    id sprite scale position ;

: (move-entity) ( entity xz -- entity )
   [ v+ ] curry change-position ;

: clipped-pos ( entity -- xz )
   position>> first2 [ floor >integer ] bi@ 2array ;

: add-entity ( stage entity -- stage )
   [ suffix ] curry change-entities ;

! == Per-Entity Action System

GENERIC#: entity-action 2 ( entity stage quots -- quots )
M: entity entity-action 2nip ;

: internal-actions ( stage -- actions )
   dup entities>> over [ { } entity-action ] curry 
   map concat nip ; 

: apply-actions ( stage actions -- )
   2dup [ entities>> ] dip [ cleave( x -- ) ] curry each
   cleave( x -- ) ; inline

: do-actions ( stage -- )
   [ internal-actions ] [ actions>> ] [ V{ } >>actions ] tri
   -rot append apply-actions ;

: add-action* ( stage quot -- stage )
   [ suffix ] curry change-actions ;

: step-entity ( entity -- entity' )
   dup blank-stage { } entity-action drop ;

: find-entity ( stage id -- entity/f )
   [ entities>> ] [ '[ id>> _ = ] ] bi* filter ?first ;

! == Baseline Action/Entity Library

GENERIC#: move-entity 2 ( subject id xz -- )
M: entity move-entity
   [ (move-entity) ] curry [ over id>> = ] dip when drop ;
M: stage move-entity
   3drop ; ! Step sounds, particles, etc.

GENERIC#: move-camera 1 ( subject xz -- )
M: object move-camera 2drop ;
M: stage move-camera 
   [ v+ ] curry change-camera-xyz drop ;

GENERIC#: rotate-camera 2 ( subject yaw pitch -- )
M: object rotate-camera 3drop ;
M: stage rotate-camera 
   [ + ] bi-curry@ [   change-camera-yaw drop ] 
                   [ change-camera-pitch drop ]    
   bi-curry* bi ;

TUPLE: timer < entity
   { ticks initial: 0 } { internal initial: { } } 
                        { external initial: { } } ;
TUPLE: timer-action
   quot when ;

: timer-actions ( timer-actions ticks -- do-now rest )
   '[ when>> _ <= ] 
      [ filter [ quot>> ] map ] [ reject ] 
   bi-curry bi ;

: do-timer ( timer -- quots )
  [ 1 + ] change-ticks dup dup
      [ internal>> ] [ external>> ] [ ticks>> ] tri
      [ timer-actions ] curry bi@ 
   [ overd >>internal drop cleave( x -- ) ]
   [ overd >>external drop ] 2bi* nip ;

M: timer entity-action ( entity stage quots -- quots )
   pick do-timer append call-next-method ;

: <fuse> ( quot ticks timer -- timer-action )
   ticks>> + timer-action boa ;

: <fuse-internal> ( timer quot ticks -- timer )
   pick <fuse> [ append ] curry change-internal ;
: <fuse-external> ( timer quot ticks -- timer )
   pick <fuse> [ append ] curry change-external ;

TUPLE: animated < timer
   animation-chart default-ani in-animation in-ani-since ;

SINGLETON: end-animation

: animation-data ( animated -- animation frame )
   { [ animation-chart>> ] [ in-animation>> ]
     [ ticks>> ] [ in-ani-since>> ] } cleave 
   [ of ] [ - 1 - ] 2bi* ;

: change-animation ( animated animation -- )
   >>in-animation dup ticks>> >>in-ani-since drop ;

: reset-animation ( animated -- )
   dup default-ani>> change-animation ;

M: animated entity-action ( entity stage quots -- quots )
   pick animation-data of
      { { [ dup string? ] [ pickd >>sprite drop ] }
        { [ dup end-animation? ] [ drop pick reset-animation ] }
      [ drop ] } cond
   call-next-method ;

: current-sprite ( animated -- sprite )
   animation-data '[ first _ >= ] filter first second ;

: coerce-sprite ( animated -- )
   dup current-sprite [ end-animation? not ]
   [ >>sprite ] [ drop ] 1if drop ;

TUPLE: angled < animated
   angle-chart current-range angle ;
! automatic handling of opposite angles?

: in-range ( low high val -- ? )
   [ <= ] [ >= ] bi-curry bi* and ;

: normalize-deg ( degrees -- degrees )
   360 mod 360 + 360 mod ;

: update-sprite-angle ( entity angle -- )
   [ dup angle-chart>> ] dip
   '[ first2 _ in-range ] filter first 
      [ >>current-range drop ] [ last >>animation-chart ]
   bi-curry bi coerce-sprite ;

: relative-angle ( entity stage -- angle )
   [ angle>> ] [ camera-yaw>> ] bi* - normalize-deg ;

M: angled entity-action ( entity stage quots -- quots )
   2over [ drop current-range>> first2 ] [ relative-angle ] 2bi
   [ in-range not ] keep swap [ pickd update-sprite-angle ] [ drop ] if
   call-next-method ;

! TUPLE: object 
!    id model position rotation ;

! == Managing State Subclasses

GENERIC: substage ( substage -- slots )

: stage-as ( [sub]stage exemplar -- substage )
   [ [ deep-clone tuple-slots ] [ substage ] bi* append ] 
   keep class-of slots>tuple ;

: <stage-as> ( [sub]stage class -- substage )
   new stage-as ;

: peel-substage ( [sub]stage -- [sub]stage slots )
   [ dup [ clone tuple-slots ] 
           [ substage length ] bi* cut* ] keep
   class-of superclass-of [ slots>tuple ] curry dip ;

: (>stage) ( slots substage -- slots stage )
! pack-tuple and restore with a reduce instead?
   [ class-of stage = ]
      [ peel-substage [ suffix ] curry dip (>stage) ]
   1unless  ;

: >stage ( substage -- stage slots ) 
   [ { } ] dip (>stage) swap ;

: restore-substage ( stage slots class -- substage )
   [ tuple-slots ] [ concat ] [ ] tri* 
   [ append ] dip slots>tuple ;