extra/ui/gadgets/canvas/canvas.factor

   1 ! Copyright (C) 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.worlds
   4 ui.render opengl opengl.gl kernel namespaces tuples colors ;
   5 IN: ui.gadgets.canvas
   6
   7 TUPLE: canvas dlist ;
   8
   9 : <canvas> ( -- canvas )
  10     canvas construct-gadget
  11     dup black solid-interior ;
  12
  13 : find-gl-context ( gadget -- )
  14     find-world world-handle select-gl-context ;
  15
  16 : delete-canvas-dlist ( canvas -- )
  17     dup find-gl-context
  18     dup canvas-dlist [ delete-dlist ] when*
  19     f swap set-canvas-dlist ;
  20
  21 : make-canvas-dlist ( canvas quot -- dlist )
  22     over >r GL_COMPILE swap make-dlist dup r>
  23     set-canvas-dlist ;
  24
  25 : cache-canvas-dlist ( canvas quot -- dlist )
  26     over canvas-dlist dup
  27     [ 2nip ] [ drop make-canvas-dlist ] if ; inline
  28
  29 : draw-canvas ( canvas quot -- )
  30     origin get [
  31         cache-canvas-dlist glCallList
  32     ] with-translation ; inline
  33
  34 M: canvas ungraft* delete-canvas-dlist ;