basis/ui/gadgets/canvas/canvas.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: ui.backend ui.gadgets ui.gadgets.worlds ui.pens.solid
   5 opengl opengl.gl kernel namespaces classes.tuple colors
   6 accessors ;
   7
   8 IN: ui.gadgets.canvas
   9
  10 TUPLE: canvas < gadget dlist ;
  11
  12 : new-canvas ( class -- canvas )
  13     new COLOR: black <solid> >>interior ; inline
  14
  15 : delete-canvas-dlist ( canvas -- )
  16     [ find-gl-context ]
  17     [ [ [ delete-dlist ] when* f ] change-dlist drop ] bi ;
  18
  19 : make-canvas-dlist ( canvas quot -- dlist )
  20     [ drop ] [ GL_COMPILE swap make-dlist ] 2bi
  21     [ >>dlist drop ] keep ; inline
  22
  23 : cache-canvas-dlist ( canvas quot -- dlist )
  24     over dlist>> dup
  25     [ 2nip ] [ drop make-canvas-dlist ] if ; inline
  26
  27 : draw-canvas ( canvas quot -- )
  28     cache-canvas-dlist glCallList ; inline
  29
  30 M: canvas ungraft* delete-canvas-dlist ;