basis/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
   4 ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
   5 classes.tuple colors accessors ;
   6 IN: ui.gadgets.canvas
   7
   8 TUPLE: canvas < gadget dlist ;
   9
  10 : new-canvas ( class -- canvas )
  11     new-gadget black solid-interior ; inline
  12
  13 : delete-canvas-dlist ( canvas -- )
  14     [ find-gl-context ]
  15     [ dlist>> [ delete-dlist ] when* ]
  16     [ f >>dlist drop ] tri ;
  17
  18 : make-canvas-dlist ( canvas quot -- dlist )
  19     [ drop ] [ GL_COMPILE swap make-dlist ] 2bi
  20     [ >>dlist drop ] keep ; inline
  21
  22 : cache-canvas-dlist ( canvas quot -- dlist )
  23     over dlist>> dup
  24     [ 2nip ] [ drop make-canvas-dlist ] if ; inline
  25
  26 : draw-canvas ( canvas quot -- )
  27     origin get [
  28         cache-canvas-dlist glCallList
  29     ] with-translation ; inline
  30
  31 M: canvas ungraft* delete-canvas-dlist ;