extra/gamelib/ui/ui.factor

   1 USING: accessors arrays classes quotations ui.gadgets kernel
   2 ui.gadgets.status-bar ui ui.render opengl locals.types strings
   3 sequences combinators peg images.loader opengl.textures assocs
   4 math ranges gamelib.board gamelib.cell-object ui.gestures
   5 ui.gadgets.tracks ui.gadgets.worlds colors destructors
   6 gamelib.loop ;
   7
   8 IN: gamelib.ui
   9
  10 TUPLE: board-gadget < gadget dimension bg-color draw-quotes board gests textures ;
  11
  12 :: get-cell-dimension ( n gadget -- celldims )
  13     ! Calculates cell height and width based on gadget height and width
  14     gadget dimension>> first2 :> ( wdt hgt )
  15     n gadget board>> nth dup width>> swap height>> :> ( cols rows )
  16
  17     wdt cols /i :> cellwidth
  18     hgt rows /i :> cellheight
  19
  20    cellwidth cellheight { } 2sequence ;
  21
  22 :: get-dimension-matrix ( n gadget -- matrix )
  23     ! gets a matrix of all starting locations of cells
  24     n gadget get-cell-dimension :> celldims
  25     ! applies appropriate offset to starting locations based on the cell heigh/width
  26     n gadget board>> nth width>> [0..b) [ celldims first * ] map :> widths
  27     n gadget board>> nth height>> [0..b) [ celldims second * ] map :> heights
  28
  29     widths heights cartesian-product flip ;
  30
  31 :: draw-append ( gadget quot -- gadget )
  32     gadget
  33     gadget draw-quotes>>
  34     quot { } 1sequence append
  35     >>draw-quotes ;
  36
  37 :: draw-background-color ( gadget -- )
  38     ! if given a background color, draw the background color
  39     gadget bg-color>>
  40     [ gadget bg-color>> gl-color { 0 0 } gadget dimension>> gl-fill-rect ]
  41     [ ] if ;
  42
  43 :: draw-filled-rectangle ( gadget color loc dim -- gadget )
  44     ! appends instruction to draw a rectangle to current set of instructions in draw-quotes attribute
  45     gadget [ color gl-color loc dim gl-fill-rect ] draw-append ;
  46
  47 :: draw-image ( gadget path loc dim -- gadget )
  48     ! appends instructions to draw a sprite to current set of instructions in draw-quotes attributes
  49     gadget [ dim { path loc } gadget textures>> [ first load-image loc <texture> ] cache draw-scaled-texture ] draw-append ;
  50     ! gadget [ dim path load-image loc <texture> draw-scaled-texture ] draw-append ;
  51
  52 :: draw-quote ( gadget quote -- gadget )
  53     gadget quote draw-append ;
  54
  55 :: draw-single ( display-cell loc dim gadget -- )
  56     ! Executes instructions based on content of the cell, does nothing if cell isn't a
  57     ! string, color or quote.
  58     {
  59         { [ display-cell cell-object instance? ] [ loc dim display-cell draw-cell-object* ] }
  60         { [ display-cell string? ] [ dim { display-cell loc } gadget textures>> [ first load-image loc <texture> ] cache draw-scaled-texture ] }
  61         { [ display-cell color? ] [ display-cell gl-color loc dim gl-fill-rect ] }
  62         { [ display-cell quotation? ] [ loc dim display-cell 2curry call( -- ) ] }
  63         { [ display-cell array? ] [ display-cell [ loc dim gadget draw-single ] each ] }
  64         [ ]
  65     } cond ;
  66
  67 :: draw-cells ( n gadget -- )
  68     ! board is always valid since this instruction gets added on creation of board
  69     n gadget board>> nth cells>> :> cell
  70     n gadget get-cell-dimension :> celldims
  71     n gadget get-dimension-matrix :> dim-matrix
  72     cell dim-matrix [ [ celldims gadget draw-single ] 2each ] 2each ;
  73
  74 : draw-all ( gadget -- )
  75     ! draws everything in draw-quotes (which we added to using draw-filled-rectangle and draw-image)
  76     draw-quotes>> [ call( -- ) ] each ;
  77
  78 ! TODO: change to have a board
  79 : init-board-gadget ( dim -- gadget )
  80     ! makes a window gadget with given dimensions
  81     board-gadget new
  82     swap >>dimension
  83     H{ } >>gests
  84     H{ } clone >>textures ;
  85
  86 :: add-board ( gadget board -- gadget )
  87     ! board should be a seq
  88     gadget board >>board
  89     [ board length [0..b) [ gadget draw-cells ] each ] draw-append ;
  90
  91 :: display ( gadget -- )
  92     [
  93         gadget
  94         "Display window"
  95         open-status-window
  96     ] with-ui ;
  97
  98 : set-background-color ( gadget color -- gadget )
  99     >>bg-color ;
 100
 101 : set-dim ( gadget dim -- gadget )
 102     >>dimension ;
 103
 104 : get-dim ( gadget -- dim )
 105     dimension>> ;
 106
 107 :: hand-rel-cell ( gadget -- cellpos )
 108     gadget hand-rel first2 :> ( w h )
 109     0 gadget get-cell-dimension first2 :> ( cw ch )
 110     w cw /i :> row
 111     h ch /i :> col
 112     row col { } 2sequence ;
 113
 114 :: new-gesture ( gadget key value -- gadget )
 115     value key gadget gests>> set-at gadget ;
 116
 117
 118 ! SECTION: gadget methods
 119 M: board-gadget pref-dim*
 120    dimension>> ;
 121
 122 M: board-gadget handle-gesture
 123     swap over gests>> ?at
 124     [
 125         2dup call( gadget -- )
 126     ] when 2drop f ;
 127
 128 M: board-gadget draw-gadget*
 129     {
 130         [ draw-background-color ]
 131         [ draw-all ]
 132     } cleave ;
 133
 134 M: board-gadget ungraft*
 135     [   dup find-gl-context [ values dispose-each H{ } clone ] change-textures drop
 136         stop-game
 137     ] [ call-next-method ] bi ;
 138
 139 TUPLE: window-gadget < track focusable-child-number ;
 140
 141 :: <window> ( board-gadgets orientation fsn constraint -- gadget )
 142     orientation window-gadget new-track
 143     fsn >>focusable-child-number
 144     board-gadgets [ constraint track-add ] each ;
 145
 146 M: window-gadget focusable-child* dup children>> swap focusable-child-number>> swap nth ;