togl.lisp

   1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
   2 #|
   3
   4     Togl Bindings and Cells/Tk Interfaces
   5
   6 Copyright (C) 2006 by Kenneth Tilton
   7
   8 This library is free software; you can redistribute it and/or
   9 modify it under the terms of the Lisp Lesser GNU Public License
  10  (http://opensource.franz.com/preamble.html), known as the LLGPL.
  11
  12 This library is distributed  WITHOUT ANY WARRANTY; without even
  13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14
  15 See the Lisp Lesser GNU Public License for more details.
  16
  17 |#
  18
  19 (in-package :celtk)
  20
  21
  22 (define-foreign-library Togl
  23   (:darwin (:or "libTogl1.7.dylib"
  24                 "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib"))
  25   (:windows (:or "togl17.dll"))
  26   (:unix "/usr/lib/Togl1.7/libTogl1.7.so"))
  27
  28 (defctype togl-struct-ptr-type :pointer)
  29
  30 ;;; --- Togl (Version 1.7 and above needed!) -----------------------------
  31
  32 (defcfun ("Togl_Init" Togl-Init) tcl-retcode
  33   (interp :pointer))
  34
  35 (defcfun ("Togl_PostRedisplay" togl-post-redisplay) :void
  36   (togl-struct-ptr :pointer))
  37
  38 (defcfun ("Togl_SwapBuffers" togl-swap-buffers) :void
  39   (togl-struct-ptr :pointer))
  40
  41 (defcfun ("Togl_Ident" Togl-Ident) :string
  42   (togl-struct-ptr :pointer))
  43
  44 (defcfun ("Togl_Width" Togl-Width) :int
  45   (togl-struct-ptr :pointer))
  46
  47 (defcfun ("Togl_Height" Togl-Height) :int
  48   (togl-struct-ptr :pointer))
  49
  50 (defcfun ("Togl_Interp" Togl-Interp) :pointer
  51   (togl-struct-ptr :pointer))
  52
  53 ;; The following functions are not CFFI-translated yet ...
  54
  55 ;; Togl_AllocColor
  56 ;; Togl_FreeColor
  57
  58 ;; Togl_LoadBitmapFont
  59 ;; Togl_UnloadBitmapFont
  60
  61 ;; Togl_SetClientData
  62 ;; Togl_ClientData
  63
  64 ;; Togl_UseLayer
  65 ;; Togl_ShowOverlay
  66 ;; Togl_HideOverlay
  67 ;; Togl_PostOverlayRedisplay
  68 ;; Togl_OverlayDisplayFunc
  69 ;; Togl_ExistsOverlay
  70 ;; Togl_GetOverlayTransparentValue
  71 ;; Togl_IsMappedOverlay
  72 ;; Togl_AllocColorOverlay
  73 ;; Togl_FreeColorOverlay
  74 ;; Togl_DumpToEpsFile
  75
  76 (eval-now!
  77   (export '(togl with-togl togl-interp togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func
  78              togl togl-timer-using-class togl-post-redisplay togl-reshape-using-class
  79              togl-display-using-class togl-width togl-height togl-create-using-class)))
  80
  81 ;; --- gotta call this bad boy during initialization, I guess any time after we have an interpreter
  82 ;;
  83
  84 (defun tk-togl-init (interp)
  85   ;(assert (not (zerop (tcl-init-stubs interp "8.1" 0)))) ;; Only meaningful on Windows
  86   ;(assert (not (zerop (tk-init-stubs interp "8.1" 0)))) ;; dito
  87   (togl-init interp)
  88   (togl-create-func (callback togl-create))
  89   (togl-destroy-func (callback togl-destroy))
  90   (togl-display-func (callback togl-display))
  91   (togl-reshape-func (callback togl-reshape))
  92   (togl-timer-func (callback togl-timer)) ;; probably want to make this optional
  93   )
  94
  95 (export! togl-ptr-set ^togl-ptr-set)
  96
  97 (deftk togl (widget)
  98   ((togl-ptr :cell nil  :initform nil :initarg :togl-ptr :accessor togl-ptr)
  99    (togl-ptr-set :initform (c-in nil) :initarg :togl-ptr-set :accessor togl-ptr-set
 100      :documentation "very complicated, don't ask (togl-ptr cannot wait on ufb processing)")
 101    (cb-create :initform nil :initarg :cb-create :reader cb-create)
 102    (cb-display :initform nil :initarg :cb-display :reader cb-display)
 103    (cb-reshape :initform nil :initarg :cb-reshape :reader cb-reshape)
 104    (cb-destroy :initform nil :initarg :cb-destroy :reader cb-destroy)
 105    (cb-timer :initform nil :initarg :cb-timer :reader cb-timer))
 106   (:tk-spec togl
 107     -width ;;           400     Width of widget in pixels.
 108     -height ;;          400     Height of widget in pixels.
 109     -ident      ;;      ""      A user identification string ignored by togl.
 110     ;;  This can be useful in your C callback functions
 111     ;;  to determine which Togl widget is the caller.
 112     -rgba       ;;      true    If true, use RGB(A) mode
 113     ;;  If false, use Color Index mode
 114     -redsize      ;;    1       Min bits per red component
 115     -greensize  ;; 1    Min bits per green component
 116     -bluesize   ;; 1    Min bits per blue component
 117     -double             ;; false        If false, request a single buffered window
 118     ;; If true, request double buffered window
 119     -depth              ;; false        If true, request a depth buffer
 120     -depthsize  ;; 1    Min bits of depth buffer
 121     -accum              ;; false        If true, request an accumulation buffer
 122     -accumredsize       ;; 1    Min bits per accum red component
 123     -accumgreensize     ;; 1    Min bits per accum green component
 124     -accumbluesize      ;; 1    Min bits per accum blue component
 125     -accumalphasize     ;; 1    Min bits per accum alpha component
 126     -alpha              ;; false        If true and -rgba is true, request an alpha
 127     ;; channel
 128     -alphasize  ;; 1    Min bits per alpha component
 129     -stencil    ;; false        If true, request a stencil buffer
 130     -stencilsize        ;; 1    Min number of stencil bits
 131     -auxbuffers ;; 0    Desired number of auxiliary buffers
 132     -privatecmap        ;; false        Only applicable in color index mode.
 133     ;; If false, use a shared read-only colormap.
 134     ;; If true, use a private read/write colormap.
 135     -overlay      ;; false   If true, request overlay planes.
 136     -stereo       ;; false   If true, request a stereo-capable window.
 137     (-timer-interval -time)  ;; 1       Specifies the interval, in milliseconds, for
 138     ;     calling the C timer callback function which
 139     ;    was registered with Togl_TimerFunc.
 140     -sharelist    ;; ""      Name of an existing Togl widget with which to
 141     ;     share display lists.
 142     ;    NOT YET IMPLEMENTED FOR WINDOWS 95/NT.
 143     -sharecontext ;; ""      Name of an existing Togl widget with which to
 144     ;     share the OpenGL context.  NOTE:  most other
 145     ;    attributes such as double buffering, RGBA vs CI,
 146     ;   ancillary buffer specs, etc are then ignored.
 147     ;  NOT YET IMPLEMENTED FOR WINDOWS 95/NT.
 148     -indirect     ;; false   If present, request an indirect rendering context.
 149     ;     A direct rendering context is normally requested.
 150     ;    NOT SIGNIFICANT FOR WINDOWS 95/NT.
 151     )
 152   (:default-initargs
 153       :double t
 154     :rgba t
 155     :alpha t
 156     :id (gentemp "TOGL")
 157     :ident (c? (^path))))
 158
 159 (defmacro with-togl ((togl-form width-var height-var) &body body &aux (togl (gensym))(togl-ptr (gensym)))
 160   `(let* ((,togl ,togl-form)
 161           (,togl-ptr (togl-ptr ,togl)))
 162      (when ,togl-ptr
 163        (let ((*tki* (togl-interp ,togl-ptr))
 164              (,width-var (togl-width ,togl-ptr))
 165              (,height-var (togl-height ,togl-ptr)))
 166          ,@body))))
 167
 168 (defmacro def-togl-callback (root (&optional (ptr-var 'togl-ptr)(self-var 'self)) &body preamble)
 169   (let ((register$ (format nil "TOGL-~a-FUNC" root))
 170         (cb$ (format nil "TOGL-~a" root))
 171         (cb-slot$ (format nil "CB-~a" root))
 172         (uc$ (format nil "TOGL-~a-USING-CLASS" root)))
 173     `(progn
 174        (defcfun (,(format nil "Togl_~:(~a~)Func" root) ,(intern register$))
 175            :void
 176          (callback :pointer))
 177        (defcallback ,(intern cb$) :void ((,ptr-var :pointer))
 178          (unless (c-stopped)
 179            (bif (,self-var (or (gethash (pointer-address ,ptr-var) (tkwins *tkw*))
 180                              (gethash (togl-ident ,ptr-var)(dictionary *tkw*))))
 181              (progn
 182                ,@preamble
 183                (trc nil "selves" ,cb$ (togl-ident ,ptr-var) (gethash (pointer-address ,ptr-var) (tkwins *tkw*))(gethash (togl-ident ,ptr-var)(dictionary *tkw*)))
 184                (,(intern uc$) ,self-var))
 185              (trc "WARNING: Togl callback ~a sees unknown togl pointer ~a :address ~a :ident ~a"
 186                ,cb$ ,ptr-var (pointer-address ,ptr-var) (togl-ident ,ptr-var)))))
 187        (defmethod ,(intern uc$) :around ((self togl))
 188          (if (,(intern cb-slot$) self)
 189                (funcall (,(intern cb-slot$) self) self)
 190              (call-next-method)))
 191        (defmethod ,(intern uc$) ((self togl))))))
 192
 193 (def-togl-callback create ()
 194   (trc "___________________ TOGL SET UP _________________________________________" togl-ptr )
 195   ;;
 196   ;; Cello dependency here: relies on :CELLO being pushed to *features*!
 197   ;;
 198   ;;(eval-when (:compile-toplevel :execute)
 199   ;;  (if (member :cello cl-user::*features*)
 200   ;;    (progn
 201   ;;      (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes
 202   ;;                                         ;; to defer FTGL till Ogl ready
 203   ;;      (kt-opengl:kt-opengl-reset))))
 204 ;;;   ^^^^^ above two needed only for cello ^^^^^^
 205 ;;;
 206   (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred
 207   (setf (togl-ptr-set self) togl-ptr) ;; this gets deferred, which is OK
 208   (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))
 209
 210 (def-togl-callback display ())
 211 (def-togl-callback reshape ())
 212 (def-togl-callback destroy ())
 213 (def-togl-callback timer ())
 214
 215 (defmethod make-tk-instance ((self togl))
 216   (with-integrity (:client `(:make-tk ,self))
 217     (setf (gethash (^path) (dictionary .tkw)) self)
 218     (trc nil "making togl!!!!!!!!!!!!" (path self)(tk-configurations self))
 219     (tk-format-now "togl ~a ~{~(~a~) ~a~^ ~}"
 220       (path self)(tk-configurations self))))