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
   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 black <solid> >>interior ; inline
  12
  13 : delete-canvas-dlist ( canvas -- )
  14     [ find-gl-context ]
  15     [ [ [ delete-dlist ] when* f ] change-dlist drop ] bi ;
  16
  17 : make-canvas-dlist ( canvas quot -- dlist )
  18     [ drop ] [ GL_COMPILE swap make-dlist ] 2bi
  19     [ >>dlist drop ] keep ; inline
  20
  21 : cache-canvas-dlist ( canvas quot -- dlist )
  22     over dlist>> dup
  23     [ 2nip ] [ drop make-canvas-dlist ] if ; inline
  24
  25 : draw-canvas ( canvas quot -- )
  26     origin get [
  27         cache-canvas-dlist glCallList
  28     ] with-translation ; inline
  29
  30 M: canvas ungraft* delete-canvas-dlist ;