extra/game/worlds/worlds.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors combinators fry game.input game.loop generic kernel math
   3 parser sequences ui ui.gadgets ui.gadgets.worlds ui.gestures threads
   4 words ;
   5 IN: game.worlds
   6
   7 TUPLE: game-world < world
   8     game-loop
   9     { tick-slice float initial: 0.0 } ;
  10
  11 GENERIC: tick-interval-micros ( world -- micros )
  12
  13 GENERIC: begin-game-world ( world -- )
  14 M: object begin-game-world drop ;
  15
  16 GENERIC: end-game-world ( world -- )
  17 M: object end-game-world drop ;
  18
  19 M: game-world draw*
  20     swap >>tick-slice relayout-1 yield ;
  21
  22 M: game-world begin-world
  23     open-game-input
  24     dup begin-game-world
  25     dup [ tick-interval-micros ] [ ] bi <game-loop> [ >>game-loop ] keep start-loop
  26     drop ;
  27
  28 M: game-world end-world
  29     [ [ stop-loop ] when* f ] change-game-loop
  30     end-game-world
  31     close-game-input ;
  32
  33 TUPLE: game-attributes < world-attributes
  34     { tick-interval-micros fixnum read-only } ;
  35
  36 <PRIVATE
  37
  38 : verify-game-attributes ( attributes -- )
  39     {
  40         [
  41             world-class>> { f world } member?
  42             [ "GAME: must be given a custom world-class" throw ] when
  43         ]
  44         [
  45             tick-interval-micros>> 0 <=
  46             [ "GAME: must be given a nonzero tick-interval-micros" throw ] when
  47         ]
  48     } cleave ;
  49
  50 : define-game-tick-interval-micros ( attributes -- )
  51     [ world-class>> \ tick-interval-micros create-method ]
  52     [ tick-interval-micros>> '[ drop _ ] ] bi
  53     define ;
  54
  55 : define-game-methods ( attributes -- )
  56     {
  57         [ verify-game-attributes ]
  58         [ define-game-tick-interval-micros ]
  59     } cleave ;
  60
  61 : define-game ( word attributes quot -- )
  62     [ define-main-window ]
  63     [ drop nip define-game-methods ] 3bi ;
  64
  65 PRIVATE>
  66
  67 SYNTAX: GAME:
  68     CREATE
  69     game-attributes parse-main-window-attributes
  70     parse-definition
  71     define-game ;