basis/ui/gadgets/canvas/canvas.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: ui.backend ui.gadgets ui.gadgets.worlds ui.pens.solid opengl
   4 opengl.gl kernel namespaces classes.tuple colors colors.constants
   5 accessors ;
   6 IN: ui.gadgets.canvas
   7
   8 TUPLE: canvas < gadget dlist ;
   9
  10 : new-canvas ( class -- canvas )
  11     new COLOR: 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     cache-canvas-dlist glCallList ; inline
  27
  28 M: canvas ungraft* delete-canvas-dlist ;