From ktilton at common-lisp.net Fri Feb 2 20:11:02 2007 From: ktilton at common-lisp.net (ktilton) Date: Fri, 2 Feb 2007 15:11:02 -0500 (EST) Subject: [cello-cvs] CVS cello Message-ID: <20070202201102.3CF1F702E2@common-lisp.net> Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv2070 Modified Files: application.lisp cello-magick.lisp cello.lisp cello.lpr control.lisp ctl-markbox.lisp ctl-toggle.lisp focus.lisp image.lisp ix-canvas.lisp ix-layer-expand.lisp ix-paint.lisp ix-togl.lisp mouse-click.lisp Log Message: --- /project/cello/cvsroot/cello/application.lisp 2006/11/13 05:29:26 1.9 +++ /project/cello/cvsroot/cello/application.lisp 2007/02/02 20:11:00 1.10 @@ -20,6 +20,8 @@ (defparameter *first-kill-all-the-windows* nil) +(export! cello-reset) + (defun cello-reset (&optional (system-type 'mg-system)) ;; Reset CFFI, CFFI Extender --- /project/cello/cvsroot/cello/cello-magick.lisp 2006/11/04 20:56:30 1.6 +++ /project/cello/cvsroot/cello/cello-magick.lisp 2007/02/02 20:11:00 1.7 @@ -53,23 +53,29 @@ (ogl::glec :snapshot) (record-frame recording pixels columns rows)))) -(defmodel ix-wander (ix-view) - ((wander :initarg :wander :accessor wander :initform nil)) ;;///just use skin? - (:default-initargs - :pre-layer (c? (with-layers (:wand (^wander)))))) - -(defmodel ix-image-file (ix-wander) - ((wand-type :initarg :wand-type :accessor wand-type :initform 'wand-pixels)) - (:default-initargs - :wander (c? (if (^value) - (let ((wand (wand-ensure-typed (^wand-type) (^value)))) - (assert wand () "Unable to load image file ~a" (^value)) - wand) - (error "ix-image-file requires value of path to image file"))) - :pre-layer (c? (with-layers +white+ (:wand (^wander)))) - :ll 0 :lt 0 :lb (c? (downs (cdr (image-size (^wander))))) - :lr (c? (car (image-size (^wander)))) - )) +(defmd ix-image-file (ix-view) + (:documentation "Quick way to drop a view of a binary JPG, PNG, GIF, etc into a Cello window") + image-path + (mode :texture :documentation ":texture or :pixel, as in OpenGL") + tilep + transparency + :value (c? (if (^image-path) + (let ((wand (wand-ensure-typed + (ecase (^mode) (:texture 'wand-texture)(:pixel 'wand-pixel)) + (^image-path) + :tilep (^tilep) + :storage (if (^transparency) gl_rgba gl_rgb)))) + (assert wand () "Unable to load image file ~a" (^value)) + wand) + (trc "ix-image-file has no path to image file!!!!!" self))) + :pre-layer (c? (bwhen (w (^value)) + (with-layers +white+ (:wand w)))) + :ll 0 :lt 0 :lb (c? (bif (w (^value)) + (downs (cdr (image-size w))) + 0)) + :lr (c? (bif (w (^value)) + (car (image-size (^value))) + 0))) (defparameter *mapping-textures* nil) --- /project/cello/cvsroot/cello/cello.lisp 2006/10/17 21:30:08 1.14 +++ /project/cello/cvsroot/cello/cello.lisp 2007/02/02 20:11:00 1.15 @@ -15,7 +15,7 @@ |# -;;; $Id: cello.lisp,v 1.14 2006/10/17 21:30:08 ktilton Exp $ +;;; $Id: cello.lisp,v 1.15 2007/02/02 20:11:00 ktilton Exp $ ;;; ============================================================================ @@ -26,7 +26,7 @@ (:nicknames :clo) (:use #:common-lisp - #-(or ccl cormanlisp sbcl) #:clos + #-(or ccl cormanlisp sbcl openmcl) #:clos #:utils-kt #:cells #:gui-geometry @@ -79,7 +79,7 @@ (setf (ogl-context self) (nearest self ctk::togl)))) (define-symbol-macro .ogc. (togl-ptr .og.)) -(define-symbol-macro .retog. (when .ogc. (togl-post-redisplay .ogc.))) +(define-symbol-macro .retog. (when (and .og. .ogc.) (togl-post-redisplay .ogc.))) ;;; ============================================================================ ;;; MISC --- /project/cello/cvsroot/cello/cello.lpr 2006/11/13 05:29:26 1.16 +++ /project/cello/cvsroot/cello/cello.lpr 2007/02/02 20:11:00 1.17 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/control.lisp 2006/11/13 05:29:26 1.8 +++ /project/cello/cvsroot/cello/control.lisp 2007/02/02 20:11:00 1.9 @@ -15,7 +15,7 @@ |# (in-package :cello) -(export! control enabled ^enabled) +(export! control enabled ^enabled ct-action-lambda) (defmd control () (title$ (c? (format nil "~:(~a~)" ;; this is just a poor default-- really s.b. supplied by form author (string-downcase (substitute #\space #\- (string (md-name self))))))) @@ -37,6 +37,11 @@ (kb-selector nil :cell nil) :gl-name (c? (incf (gl-name-highest .w.)))) +(defmacro ct-action-lambda (&body body) + `(lambda (self event) + (declare (ignorable self event)) + , at body)) + (defmethod kb-selector (other) (declare (ignore other)) nil) (defobserver click-repeat-event () --- /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/11/13 05:29:26 1.11 +++ /project/cello/cvsroot/cello/ctl-markbox.lisp 2007/02/02 20:11:00 1.12 @@ -63,9 +63,9 @@ (:default-initargs :enabled t :value (c? (find (associated-value self) (value (^radio)))) - :ct-action (lambda (self event) - (with-cc :ct-radio-item - (radio-item-to-value self event (^radio)))))) + :ct-action (ct-action-lambda + (with-cc :ct-radio-item + (radio-item-to-value self event (^radio)))))) (defun radio-item-to-value (self event radio) @@ -89,7 +89,7 @@ (defobserver .value ((self ct-radio)) ;; /// should every control have this? (when (^on-change) - (trcx radio-value-observer self new-value old-value old-value-boundp) + ;(trcx radio-value-observer self new-value old-value old-value-boundp) (funcall (^on-change) self new-value old-value old-value-boundp))) (defmodel ct-radio-row (ct-radio) @@ -137,11 +137,10 @@ :text$ (c? (title$ .parent)) :style-id :button))) - :ct-action (lambda (self event) - (declare (ignorable event)) - (trc nil "checktext bingo" (not (value self))) - (with-cc :check-text-action - (setf (value self) (not (value self))))))) + :ct-action (ct-action-lambda + (trc nil "checktext bingo" (not (value self))) + (with-cc :check-text-action + (setf (value self) (not (value self))))))) (defmodel ct-radio-labeled (ix-row ct-radio-item) () --- /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/11/13 05:29:26 1.10 +++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2007/02/02 20:11:00 1.11 @@ -39,8 +39,7 @@ (value (c-in nil) :cell :ephemeral) (inset (mkv2 (upts 4) (upts 4)) :unchanged-if 'v2=) (depressed (c? (^hilited))) - :ct-action (lambda (self event) - (declare (ignore event)) + :ct-action (ct-action-lambda (with-cc :button-press .retog. (setf (^value) t))) @@ -89,10 +88,9 @@ `(make-instance 'ct-button :fm-parent *parent* :title$ ,text - :ct-action (lambda (self event) - (declare (ignorable self event)) - (with-cc :ct-button-ex-ct-action - ,command)) + :ct-action (ct-action-lambda + (with-cc :ct-button-ex-ct-action + ,command)) , at initargs)) (defmodel ct-selectable-button (ct-selectable ct-button)()) @@ -112,12 +110,11 @@ #'eql))) (car state-table))) - :ct-action (lambda (self event) - (declare (ignorable event)) - (trc "twister ct-action" self event) - (with-integrity (:change :ctfsm-action) - (let ((newv (funcall (transition-fn self) (value self) (states self)))) - (ct-fsm-assume-value self newv)))))) + :ct-action (ct-action-lambda + (trc "twister ct-action" self event) + (with-integrity (:change :ctfsm-action) + (let ((newv (funcall (transition-fn self) (value self) (states self)))) + (ct-fsm-assume-value self newv)))))) (defmethod ct-fsm-assume-value (self new-value) (setf (value self) new-value)) @@ -149,15 +146,7 @@ '((4 . -2) (9 . -7) (4 . -12)))) :ll 0 :lt 0 :lr (u96ths 15) :lb (downs (u96ths 15)))) -(defmethod (setf .value) :around (new (self ct-twister)) - (trcx ct-twister-value-set!!!!!!!!!!!! self new) - (call-next-method)) - -(defobserver .value ((self ct-twister)) - (when (eq :show-contents (md-name self)) - (trcx contents-twister-value-changing!!!!!!! new-value old-value old-value-boundp))) - -(export! a-twister) +(export! a-twister ix-twister ct-radio-tree expanded ^initial-open initial-open ^selectedp selectedp) (defmacro a-twister ((label component-args initial-open &rest twister-args) twisted-widget) `(a-stack (, at component-args) @@ -173,13 +162,75 @@ :text$ ,label :style-id :button) label)) ;; actually should be a form to build a widget - (a-stack (:collapsed (c? (eko ("collapsed!!!!!!!!!!!!" .cause) + (a-stack (:collapsed (c? (eko (nil "collapsed!!!!!!!!!!!!" .cause) (let ((tw (fm^ :show-contents))) (assert (eq .parent (fm-parent (fm-parent tw)))) (not (value tw)))))) ,twisted-widget))) +(defmd ix-twister (ix-stack) + label + initial-open + twisted-widget + :kids (c? (let ((label (^label))) + (the-kids + (a-stack () + (a-row () + (or (car .cache) + (make-kid 'ct-twister + :md-name :show-contents + :value (c?n (initial-open (u^ ix-twister))) + :visible (c? (^enabled)))) + (if (stringp label) + (make-kid 'ix-text + :text$ label + :style-id :button) + label)) + (a-stack (:px 8 :collapsed (c? (let ((tw (fm^ :show-contents))) + (not (value tw))))) + (let ((spec (twisted-widget (u^ ix-twister)))) + (apply 'make-instance (car spec) + :fm-parent self (cdr spec))))))))) + +(export! selectorp selection label ^selectorp ^selection ^label tree-label ^tree-label + ^kids-factory kids-factory) + +(defmd ct-radio-tree (ix-stack control) + (tree-label (c? (princ (^value)))) + selectorp + (selectedp (c? (eq self (selection (selector self))))) + selection + label + initial-open + (expanded (c? (or (fm-descendant-if self 'selectedp) + (unless .cache (^initial-open))))) + kids-factory + :kids (c? (let ((label (^tree-label)) + (tree self)) + (the-kids + (if (stringp label) + (make-kid 'ct-button + :text$ label + :style-id :button + :ct-action (ct-action-lambda + #+ugly (with-cc :ct-radio-item-focus-clear + (setf .focus nil)) + (with-cc :ct-radio-item + #+xxx (trcx tree-sets-sel (selector self) tree) + (setf (selection (selector self)) tree)))) + label) + (bwhen (f (^kids-factory)) + (a-stack (:px 8 :collapsed (c? (not (expanded tree)))) + (funcall f self))))))) + +(defgeneric selectedp (self) + (:method (self) (declare (ignore self)) nil)) + +(defgeneric selectorp (self) + (:method (self) (declare (ignore self)) nil)) +(defmethod selector (self) + (fm-ascendant-if self 'selectorp)) #| vestigial? --- /project/cello/cvsroot/cello/focus.lisp 2006/11/13 05:29:26 1.5 +++ /project/cello/cvsroot/cello/focus.lisp 2007/02/02 20:11:00 1.6 @@ -34,13 +34,12 @@ it without it being a kid there |# -(eval-now! - (export '(^focus focus))) + (defmodel focuser (ix-canvas) ( (focus :initarg :focus - :initform (c-in nil) + :initform (c-input-dbg nil) :accessor focus) (textual-focus :initarg :textual-focus @@ -80,6 +79,10 @@ ; (mkPart :selBox (IXEditSelection)) )))) + +(export! ^focus focus .focus) +(define-symbol-macro .focus (focus .tkw)) + (defun focuser (self) (swdw) ) --- /project/cello/cvsroot/cello/image.lisp 2006/11/04 20:56:30 1.17 +++ /project/cello/cvsroot/cello/image.lisp 2007/02/02 20:11:00 1.18 @@ -68,6 +68,12 @@ ; (.window-cache :cell nil :initarg :window-cache :initform nil :accessor window-cache))) +(defobserver pre-layer () + .retog.) + +(defobserver visible () + .retog.) + ;;------- IXFamily ----------------------------- ;; (defmodel ix-family (ix-view family) @@ -279,6 +285,7 @@ (defmacro with-layers (&rest layers) (flet ((collect-output (layers) + ;;(print (list "layers are" layers)) (let (output) (dolist (layer layers) (typecase layer --- /project/cello/cvsroot/cello/ix-canvas.lisp 2006/10/17 21:30:08 1.5 +++ /project/cello/cvsroot/cello/ix-canvas.lisp 2007/02/02 20:11:00 1.6 @@ -16,6 +16,8 @@ (in-package :cello) + + (defmodel ix-canvas (ix-family) ( (target-res :initarg :target-res --- /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/11/03 13:38:24 1.10 +++ /project/cello/cvsroot/cello/ix-layer-expand.lisp 2007/02/02 20:11:00 1.11 @@ -21,30 +21,32 @@ (defmethod ix-layer-expand ((key (eql :rgba)) &rest args) `(ix-render-rgba ,(car args))) +(export! ix-render-rgba) + (defun ix-render-rgba (rgba) (gl-color4fv (rgba-fo rgba))) -(defmacro def-layer-expansion (color) +(defmacro def-layer-rgba-expansion (color) `(defmethod ix-layer-expand ((key (eql ',color)) &rest args) (declare (ignore args)) `(ix-render-rgba ,',color))) -(def-layer-expansion +white+) -(def-layer-expansion +red+) -(def-layer-expansion +dark-green+) -(def-layer-expansion +green+) -(def-layer-expansion +turquoise+) -(def-layer-expansion +dark-blue+) -(def-layer-expansion +blue+) -(def-layer-expansion +light-blue+) -(def-layer-expansion +black+) -(def-layer-expansion +yellow+) -(def-layer-expansion +light-yellow+) -(def-layer-expansion +purple+) -(def-layer-expansion +gray+) -(def-layer-expansion +light-gray+) -(def-layer-expansion +dark-gray+) +(def-layer-rgba-expansion +white+) +(def-layer-rgba-expansion +red+) +(def-layer-rgba-expansion +dark-green+) +(def-layer-rgba-expansion +green+) +(def-layer-rgba-expansion +turquoise+) +(def-layer-rgba-expansion +dark-blue+) +(def-layer-rgba-expansion +blue+) +(def-layer-rgba-expansion +light-blue+) +(def-layer-rgba-expansion +black+) +(def-layer-rgba-expansion +yellow+) +(def-layer-rgba-expansion +light-yellow+) +(def-layer-rgba-expansion +purple+) +(def-layer-rgba-expansion +gray+) +(def-layer-rgba-expansion +light-gray+) +(def-layer-rgba-expansion +dark-gray+) (defmethod ix-layer-expand ((key (eql :fill)) &rest args) @@ -115,6 +117,7 @@ (defmethod ix-layer-expand ((self (eql :poly-mode)) &rest args) `(gl-polygon-mode ,(car args) ,(cadr args))) + (defmethod ix-layer-expand ((self (eql :nice-lines)) &rest args) `(progn (gl-disable gl_texture_2d) --- /project/cello/cvsroot/cello/ix-paint.lisp 2006/11/04 20:56:30 1.8 +++ /project/cello/cvsroot/cello/ix-paint.lisp 2007/02/02 20:11:01 1.9 @@ -93,7 +93,7 @@ (assert (functionp pre-layer)) (count-it :pre-layer) (nr-make ixr-box (ll self) (lt self) (lr self) (lb self)) - (trc nil "calling pre-layer" self) + (trc self "calling pre-layer" self) (funcall pre-layer self ixr-box :before) (call-next-method self) (funcall pre-layer self ixr-box :after)) --- /project/cello/cvsroot/cello/ix-togl.lisp 2006/11/13 05:29:26 1.16 +++ /project/cello/cvsroot/cello/ix-togl.lisp 2007/02/02 20:11:01 1.17 @@ -22,52 +22,52 @@ ;------------- Window --------------- ; -(export! mouse-view ^mouse-view mouse-pos ^mouse-pos mouse-control ^mouse-control mouse-down-evt ^mouse-down-evt) +(export! mouse-view-tracker mouse-view ^mouse-view mouse-pos ^mouse-pos mouse-control ^mouse-control mouse-down-evt ^mouse-down-evt) -(defmodel ix-togl ( #+not focuser ogl-lit-scene control ogl-shared-resource-tender togl ix-view) - ( - (redisplayp :cell nil :initarg :redisplayp :initform nil :accessor redisplayp) - (display-continuous :initarg :display-continuous :initform nil :accessor display-continuous) - (activep :initarg :activep :initform nil :accessor activep) - - (mouse-pos :initarg :mouse-pos :initform (c-in nil) :accessor mouse-pos) ;logical coords. Try to maintain for now. - - (mouse-view :initarg :mouse-view :accessor mouse-view - :initform (c? (let ((mp (^mouse-pos))) - (trc nil "mouseview sees pos" .w. mp) - (when mp - (eko (nil "ix-togl mouseview >" self) - (without-c-dependency - (find-ix-under self mp))))))) +(defmd mouse-view-tracker () + (mouse-view :initarg :mouse-view :accessor mouse-view + :initform (c? (let ((pos (mouse-pos .og.))) + (trc nil "mouseview sees pos" .w. pos) + (when pos + (eko (nil "ix-togl mouseview >" self) + (without-c-dependency + (find-ix-under self pos))))))) + (:documentation "Mixin to have mouse view tracked in a subtree of the window, mostly so other GUI layout can depend on +the sub-tree layout without creating a cyclic dependency, as would happen if the whole window were watched.")) + +(defmd ix-togl (mouse-view-tracker #+not focuser ogl-lit-scene control ogl-shared-resource-tender togl ix-view) + (redisplayp nil :cell nil) + display-continuous + activep + (mouse-pos :initform (c-in nil)) ;logical coords. Try to maintain for now. - (mouse-control :initarg :mouse-control :accessor mouse-control - :initform (c? (bwhen (node (^mouse-view)) - (eko (nil "possible mousecontrol" node) - (fm-ascendant-if node #'fully-enabled))))) + (mouse-control (c? (bwhen (node (^mouse-view)) + (eko (nil "possible mousecontrol" node) + (fm-ascendant-if node #'fully-enabled))))) - (mouse-up-evt :cell :ephemeral :initarg :mouse-up-evt :initform (c-in nil) :accessor mouse-up-evt) - (mouse-down-evt :cell :ephemeral :initarg :mouse-down-evt :initform (c-in nil) :accessor mouse-down-evt) - (double-click? :initform (c-in nil) :accessor double-click?) + (mouse-up-evt (c-in nil) :cell :ephemeral) + (mouse-down-evt (c-in nil) :cell :ephemeral) + (double-click? (c-in nil)) - (tick-count :initarg :tick-count :initform (c-in nil) :accessor tick-count) - (tick-fine :initarg :tick-fine :initform (c-in nil) :accessor tick-fine) - ) - (:default-initargs - :px 0 :py 0 - :gl-name (c-in nil) - :activep (c-in nil) - :clear-rgba (list 0 0 0 1) - - :ll 0 :lt 0 - :lr (c-in (scr2log 1400)) - :lb (c-in (scr2log -800)) + (tick-count (c-in nil)) + (tick-fine (c-in nil)) + :px 0 :py 0 + :gl-name (c-in nil) + :activep (c-in nil) + :clear-rgba (list 0 0 0 1) - ;;:cursor (c? (context-cursor (^mouse-control) (^keyboard-modifiers))) - - :tick-count (c-in (os-tickcount)) - :clipped t - :event-handler 'ix-togl-event-handler - )) + :ll 0 :lt 0 + :lr (c-in (scr2log 1400)) + :lb (c-in (scr2log -800)) + :tick-count (c-in (os-tickcount)) + :clipped t + :event-handler 'ix-togl-event-handler + ) + +(defmethod ctk::togl-create-using-class :around ((self ix-togl)) + (setf cl-ftgl:*ftgl-ogl* (togl-ptr self)) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready + (kt-opengl:kt-opengl-reset) + (call-next-method)) (defmethod ctk::togl-display-using-class ((self ix-togl)) (unless (or *ogl-listing-p* ;; re-entrance happens if a DLL puts up a MessageBox --- /project/cello/cvsroot/cello/mouse-click.lisp 2006/10/13 05:57:27 1.7 +++ /project/cello/cvsroot/cello/mouse-click.lisp 2007/02/02 20:11:01 1.8 @@ -16,6 +16,8 @@ (in-package :cello) +(export! os-event) + (defmodel mouse () ((leftb :initarg :leftb :initform (c-in :up) :accessor leftb) (middleb :initarg :middleb :initform (c-in :up) :accessor middleb) From ktilton at common-lisp.net Fri Feb 2 20:11:02 2007 From: ktilton at common-lisp.net (ktilton) Date: Fri, 2 Feb 2007 15:11:02 -0500 (EST) Subject: [cello-cvs] CVS cello/cffi-extender Message-ID: <20070202201102.975901202C@common-lisp.net> Update of /project/cello/cvsroot/cello/cffi-extender In directory clnet:/tmp/cvs-serv2070/cffi-extender Modified Files: arrays.lisp callbacks.lisp cffi-extender.asd cffi-extender.lpr definers.lisp Log Message: --- /project/cello/cvsroot/cello/cffi-extender/arrays.lisp 2006/09/05 23:05:36 1.4 +++ /project/cello/cvsroot/cello/cffi-extender/arrays.lisp 2007/02/02 20:11:02 1.5 @@ -1,5 +1,5 @@ ;;; -;;; Copyright ? 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -112,9 +112,10 @@ (cons (fgn-type g)(fgn-ptr g)))))) (if fgn (setf *gl-rsrc* (delete fgn *gl-rsrc*)) - (format t "~&Freeing unknown GL resource ~a" (cons type resource))) - #+nonono (ecase type - (:texture (ogl:ogl-texture-delete resource))))) + (progn + ;(format t "~&ignoring unknown GL resource ~a" (cons type resource)) + #+not (ecase type + (:texture (ogl:ogl-texture-delete resource))))))) (defmacro make-ff-array (type &rest values) (let ((fv (gensym))(n (gensym))(vs (gensym))) @@ -179,6 +180,7 @@ (setf (ff-elt v :unsigned-char n) value)) (defun eltuc (v n) + (declare (fixnum n)) (ff-elt v :unsigned-char n)) (defun eltf (v n) --- /project/cello/cvsroot/cello/cffi-extender/callbacks.lisp 2006/07/06 22:09:10 1.2 +++ /project/cello/cvsroot/cello/cffi-extender/callbacks.lisp 2007/02/02 20:11:02 1.3 @@ -1,5 +1,5 @@ ;;; -;;; Copyright ? 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/cffi-extender/cffi-extender.asd 2006/06/04 00:09:53 1.1 +++ /project/cello/cvsroot/cello/cffi-extender/cffi-extender.asd 2007/02/02 20:11:02 1.2 @@ -12,10 +12,10 @@ :licence "Lisp Lesser GNU Public License" :description "CFFI Add-ons" :long-description "Extensions and utilities for CFFI" - :depends-on (cffi cffi-uffi-compat) + :depends-on (cffi cffi-uffi-compat utils-kt) :serial t :components ((:file "cffi-extender") (:file "my-uffi-compat") (:file "definers") (:file "arrays") - (:file "callbacks"))) \ No newline at end of file + (:file "callbacks"))) --- /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2006/11/13 05:29:27 1.7 +++ /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2007/02/02 20:11:02 1.8 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/cffi-extender/definers.lisp 2006/07/06 22:09:10 1.2 +++ /project/cello/cvsroot/cello/cffi-extender/definers.lisp 2007/02/02 20:11:02 1.3 @@ -1,5 +1,5 @@ ;;; -;;; Copyright ? 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal From ktilton at common-lisp.net Fri Feb 2 20:11:04 2007 From: ktilton at common-lisp.net (ktilton) Date: Fri, 2 Feb 2007 15:11:04 -0500 (EST) Subject: [cello-cvs] CVS cello/cl-ftgl Message-ID: <20070202201104.7EE1E1701C@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv2070/cl-ftgl Modified Files: cl-ftgl.lisp cl-ftgl.lpr Log Message: --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/10/13 05:57:27 1.16 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2007/02/02 20:11:02 1.17 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-ftgl; -*- ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.16 2006/10/13 05:57:27 ktilton Exp $ +;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.17 2007/02/02 20:11:02 ktilton Exp $ (eval-when (:compile-toplevel :load-toplevel) (pushnew :cl-ftgl *features*)) @@ -54,34 +54,35 @@ (in-package :cl-ftgl) +;;; NOTE: Must build the ftgl-int/FTGLFromC.cpp glue library. (define-foreign-library FTGL - (:darwin (:or "/opt/common-lisp/cello/cl-ftgl/ftgl-int/libFTGLint.dylib")) + (:darwin "libfgc.dylib") (:windows (:or "/0dev/user/dynlib/ftgl_dynamic_MTD_d.dll"))) ;;(use-foreign-library FTGL) - frgo: This leads to problems on OS X !!! ;; -> Use function cl-ftgl-init ! -(defparameter *gui-style-default-face* 'sylfaen) -(defparameter *gui-style-button-face* 'sylfaen) +(defparameter *gui-style-default-face* + #-cffi-features:darwin 'sylfaen + #+cffi-features:darwin "Helvetica") + +(defparameter *gui-style-button-face* + #-cffi-features:darwin 'sylfaen + #+cffi-features:darwin "Helvetica") + (defparameter *ftgl-loaded-p* nil) (defparameter *ftgl-fonts-loaded* nil) (defparameter *ftgl-ogl* nil) (defparameter *ftgl-font-pathnames-list* - #+(or win32 windows mswindows) + #+cffi-features:windows (list (make-pathname :directory '(:absolute "Windows" "fonts"))) - #+linux - (list - (make-pathname - :directory - '(:absolute "usr" "share" "truetype"))) - - #+macosx + #+cffi-features:darwin (list (make-pathname :directory @@ -92,18 +93,21 @@ (make-pathname :directory '(:relative "~" "Library" "Fonts"))) + + #+(and cffi-features:unix (not cffi-features:darwin)) + (list + (make-pathname + :directory + '(:absolute "usr" "share" "truetype"))) ) (defparameter *ftgl-font-types-list* ;; list of font types ;; (font filename endings) - #+(or win32 windows mswindows) - '("ttf") - - #+linux - '("ttf") - - #+macosx + #+cffi-features:darwin '("dfont" "ttf") + + #+(or cffi-features:windows (and cffi-features:unix (not cffi-features:darwin))) + '("ttf") ) --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/11/13 05:29:28 1.10 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2007/02/02 20:11:03 1.11 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Fri Feb 2 20:11:09 2007 From: ktilton at common-lisp.net (ktilton) Date: Fri, 2 Feb 2007 15:11:09 -0500 (EST) Subject: [cello-cvs] CVS cello/cl-ftgl/ftgl-int Message-ID: <20070202201109.378231900F@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl/ftgl-int In directory clnet:/tmp/cvs-serv2070/cl-ftgl/ftgl-int Modified Files: FTGLFromC.cpp Log Message: --- /project/cello/cvsroot/cello/cl-ftgl/ftgl-int/FTGLFromC.cpp 2006/08/26 16:09:36 1.3 +++ /project/cello/cvsroot/cello/cl-ftgl/ftgl-int/FTGLFromC.cpp 2007/02/02 20:11:04 1.4 @@ -1,3 +1,12 @@ +/* Building on MacOSX: + * + * g++ -bundle FTGLFromC.cpp -o libfgc.dylib -I/path/to/FTGL/include/ \ + * -I/usr/X11R6/include/ -I/usr/X11R6/include/freetype2 \ + * -L/path/to/where/libftgl.a/is/ \ + * -L/System/Library/Frameworks/OpenGL.framework/Libraries/ \ + * -lftgl -lfreetype -lz -lGL -lGLU -lobjc + */ + /* ;;; ;;; Copyright ? 2004 by Kenneth William Tilton. From ktilton at common-lisp.net Fri Feb 2 20:11:14 2007 From: ktilton at common-lisp.net (ktilton) Date: Fri, 2 Feb 2007 15:11:14 -0500 (EST) Subject: [cello-cvs] CVS cello/cl-magick Message-ID: <20070202201114.799A51E072@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv2070/cl-magick Modified Files: cl-magick.lisp cl-magick.lpr drawing-wand.lisp magick-wand.lisp mgk-utils.lisp pixel-wand.lisp wand-image.lisp wand-pixels.lisp wand-texture.lisp Log Message: --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/11/13 05:29:28 1.14 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2007/02/02 20:11:09 1.15 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: cl-magick.lisp,v 1.14 2006/11/13 05:29:28 ktilton Exp $ +;;; $Id: cl-magick.lisp,v 1.15 2007/02/02 20:11:09 ktilton Exp $ (defpackage :cl-magick @@ -28,9 +28,10 @@ (:use #:common-lisp #:gui-geometry - #-(or cormanlisp ccl sbcl) #:clos + #-(or cormanlisp ccl sbcl openmcl) #:clos #:cffi #:cffi-extender + #:utils-kt #+kt-opengl #:kt-opengl ;; wands as opengl textures ) @@ -70,7 +71,9 @@ (defparameter *mgk-version* (fgn-alloc :unsigned-long 1)) (cffi:define-foreign-library Magick - (:darwin (:or "/usr/local/lib/libMagick.dylib")) + (:darwin #-(and)(:framework "GraphicsMagick") + "libGraphicsMagick.dylib" + "libGraphicsMagickWand.dylib") (:windows (:or #+not "C:\\Program Files\\ImageMagick-6.2.7-Q8\\CORE_RL_wand_.dll" "C:\\Program Files\\GraphicsMagick-1.1.7-Q8\\CORE_RL_wand_.dll"))) @@ -105,21 +108,21 @@ do (wand-release (cdr wand))) (setf (wands-loaded) nil)) -(defun wand-ensure-typed (wand-type file-path$ &rest iargs) - (when file-path$ +(defun wand-ensure-typed (wand-type path &rest iargs) + (when path (cl-magick-init) - (let ((key (list* wand-type (namestring file-path$) iargs))) + (let ((key (list* wand-type (namestring path) iargs))) (or (let ((old (cdr (assoc key (wands-loaded) :test 'equal)))) - #+shhh (when old - (print `(wand-ensure-typed re-using-prior-load ,wand-type ,file-path$))) + #+shhh (when old + (format t "!&wand-ensure-typed re-using cached ~a ~a" path wand-type)) old) (let ((wi (apply 'make-instance wand-type - :file-path$ file-path$ + :image-path path iargs))) - ;;(print `(wand-ensure-typed forced-to-load ,wand-type ,file-path$)) + ;;(print `(wand-ensure-typed forced-to-load ,wand-type ,path)) (push (cons key wi) (wands-loaded)) wi) - (error "Unable to load image file ~a" file-path$))))) + (error "Unable to load image file ~a" path))))) #+allegro (defun xim () --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/11/13 05:29:28 1.9 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2007/02/02 20:11:09 1.10 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 29, 2007 18:02)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/cl-magick/drawing-wand.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-magick/drawing-wand.lisp 2007/02/02 20:11:09 1.2 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/cl-magick/magick-wand.lisp 2006/08/21 04:28:28 1.3 +++ /project/cello/cvsroot/cello/cl-magick/magick-wand.lisp 2007/02/02 20:11:09 1.4 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/cl-magick/mgk-utils.lisp 2006/07/06 22:09:11 1.2 +++ /project/cello/cvsroot/cello/cl-magick/mgk-utils.lisp 2007/02/02 20:11:09 1.3 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -36,7 +36,7 @@ (wand-images-write (recording-wand recording) (namestring (recording-pathname recording)) - 1)) + t)) (defun recording-destroy (recording) (when (recording-wand recording) @@ -94,7 +94,7 @@ (error "MagickSetImagePixels failed preparing ~a" (namestring path$)) (magick-flip-image wand))))) -(defun wand-images-write (mgk-wand path$ adjoin) +(defun wand-images-write (mgk-wand path$ &optional adjoin) (print `(wand-images-write ,(magick-get-image-index mgk-wand))) (when (zerop (magick-write-images mgk-wand (namestring path$) (if adjoin 1 0))) - (error "MagickWriteImage failed writing ~a" (namestring path$)))) \ No newline at end of file + (break "MagickWriteImage failed writing ~a" (namestring path$)))) \ No newline at end of file --- /project/cello/cvsroot/cello/cl-magick/pixel-wand.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-magick/pixel-wand.lisp 2007/02/02 20:11:09 1.2 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2006/10/02 02:59:18 1.9 +++ /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2007/02/02 20:11:09 1.10 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -22,15 +22,19 @@ (in-package :cl-magick) +(export! wand-direction image-path image-size tilep) + (defclass wand-image () - ((direction :initarg :direction :initform :input :accessor direction) - (file-path$ :initarg :file-path$ :initform nil :accessor file-path$) + ((wand-direction :initarg :wand-direction :initform :input :accessor wand-direction) + (image-path :initarg :image-path :initform nil :accessor image-path) (mgk-wand :initarg :mgk-wand :initform nil :accessor mgk-wand) (image-size :initarg :image-size :initform nil :accessor image-size) - (tile-p :initarg :tile-p :initform t :accessor tile-p))) + (storage :initarg :storage :initform GL_RGB :accessor storage) + (tilep :initarg :tilep :initform t :accessor tilep) + )) (defmethod initialize-instance :after ((self wand-image) &key) - (ecase (direction self) + (ecase (wand-direction self) (:output (progn (assert (pixels self)) (assert (image-size self)) @@ -42,11 +46,11 @@ (magick-set-image-type (mgk-wand self) 3) )) (:input - (assert (probe-file (file-path$ self)) () - "Image file ~a not found initializing wand" (file-path$ self)) + (assert (probe-file (image-path self)) () + "Image file ~a not found initializing wand" (image-path self)) (assert (not (mgk-wand self))) ;; make sure not leaking - (setf (mgk-wand self) (path-to-wand (file-path$ self))) - ;;(mgk-wand-dump (mgk-wand self) (file-path$ self)) + (setf (mgk-wand self) (path-to-wand (image-path self))) + ;;(mgk-wand-dump (mgk-wand self) (image-path self)) (when (and (mgk-wand self) (not (image-size self))) (setf (image-size self) (cons (magick-get-image-width (mgk-wand self)) @@ -67,70 +71,93 @@ (assert (probe-file p)) (let ((stat (magick-read-image wand p))) (if (zerop stat) - (format t "~&magick-read jpeg failed on ~a" p) - #+shhh (format t "~&magick-read-OK ~a" p))) - wand)) - -(defparameter *mgk-columns* - (fgn-alloc :unsigned-long 1 :ignore)) - -(defparameter *mgk-rows* - (fgn-alloc :unsigned-long 1 :ignore)) - -(defun wand-image-size (wand) - (magick-get-size wand - *mgk-columns* - *mgk-rows*) - (cons (ff-elt *mgk-columns* :unsigned-long 0) - (ff-elt *mgk-rows* :unsigned-long 0))) - -(defun wand-get-image-pixels (wand - &optional (first-col 0) (first-row 0) - (last-col (magick-get-image-width wand)) - (last-row (magick-get-image-height wand))) + (format t "~&magick-read-image failed on ~a" p) ;; and return NIL ;; kt 2006-11-21 + (progn + #+shhh (format t "~&magick-read-OK ~a" p) + wand))))) + +(defun wand-get-image-pixels (self &optional (first-col 0) (first-row 0) + (last-col (magick-get-image-width (mgk-wand self))) + (last-row (magick-get-image-height (mgk-wand self))) + &aux (wand (mgk-wand self)) + (bytes-per-pixel (ecase (storage self) (#.gl_rgb 3)(#.gl_rgba 4)))) + (declare (fixnum bytes-per-pixel)) (if (zerop (* last-col last-row)) (let* ((columns 64)(rows 64) - (pixels (fgn-alloc :unsigned-char (* 3 columns rows) :wand-image))) + (pixels (fgn-alloc :unsigned-char (* bytes-per-pixel columns rows) :wand-image))) (print "wand-get-image-pixels > wand has zero pixels; did the load fail?") (dotimes (pn (* columns rows)) (setf (elti pixels pn) -1)) (values pixels columns rows)) - + (let* ((columns (- last-col first-col)) (rows (- last-row first-row)) - (pixels (fgn-alloc :unsigned-char (* 3 columns rows) :wand-image))) - (assert (not (zerop pixels))() "wand-get-image-pixels > fgn-alloc of ~a bytes failed" (* 3 columns rows)) - ;;(print (list "wand-get-image-pixels got" wand (* 3 columns rows) pixels)) ;; frgo: debug ... - (cells:trc nil "image format" wand (magick-get-image-format wand)) ;; frgo:debug... - ; - ; these next two are quite slow thx to FFI I guess - ; - #+pretty! ;; random noise texture and pixmap - (dotimes (off (* 3 columns rows)) - (setf (eltuc pixels off) (random 256))) - - #+zerosowecanseewhatreallygetsread - (dotimes (off (* 3 columns rows)) - (setf (eltuc pixels off) 0)) - - (magick-get-image-pixels wand first-col first-row columns rows "RGB" 0 pixels ) - ;;(print `(writeimage ,(magick-write-image wand "/tmp/wand-image-test.jpg"))) - #+shhh (progn + (fmt (intern (string-upcase (magick-get-image-format wand)) :mgk)) + (storage$ (ecase (storage self) (#.gl_rgb "RGB")(#.gl_rgba "RGBA"))) + (pixels (fgn-alloc :unsigned-char (* bytes-per-pixel columns rows) :wand-image))) + (declare (ignorable fmt)) + (assert (not (null-pointer-p pixels))() "wand-get-image-pixels > fgn-alloc of ~a bytes failed" (* bytes-per-pixel columns rows)) + #+shhh (cells:trc nil "cols, rows, image format" last-col last-row wand fmt bytes-per-pixel storage$) + + + (magick-get-image-pixels wand first-col first-row columns rows storage$ 0 pixels ) + + #+shhh (cells:trc "doing cols rows image!!!!!!!!!!!!!" rows columns (* columns rows) + :img-type (magick-get-image-type (mgk-wand self))) + + + (when (find fmt '(gif png)) ; - ; look at a few pixels + ; fix alpha channel which gets written out inverted for some strange reason I forget ; - (print (list "a few pixels from" wand)) - (block sweet-16 - (loop for row below rows do - (loop with bytes - for bytecol below (* 3 columns) - for offset = (+ (* row columns 3) bytecol) - for char = (eltuc pixels offset) - until (> (length bytes) 15) - unless (zerop char) - do (pushnew char bytes) - finally (format t "~&sixteen bytes ~{~a ~}" bytes) - (return-from sweet-16))))) - + (unless (block detect-converted + (loop for pixel-col fixnum below columns + for pixel-offset fixnum = (the fixnum (+ 3 (* pixel-col bytes-per-pixel))) + when (/= 255 (eltuc pixels (the fixnum pixel-offset))) + do (cells:trc "image alpha already converted. I see non-255" (eltuc pixels (the fixnum pixel-offset)) :at-col pixel-col) + (return-from detect-converted t))) + (cells:trc "converting alpha channel!!!!!!!!!!!!!!!!!!!" self) + + (loop with pix1 + for row fixnum below rows + do (loop for pixel-col fixnum below columns + for pixel-offset fixnum = (the fixnum (+ 3 (the fixnum (* (+ (* row columns) pixel-col) bytes-per-pixel)))) + do (let ((alpha (eltuc pixels pixel-offset))) + (unless pix1 + (when (zerop alpha) + (cells::trcx binogo-pix1 pixel-col row) + (setf pix1 (cons pixel-col row)))) + (setf (eltuc pixels (the fixnum pixel-offset)) (- 255 alpha)))) + ;;when (zerop (eltuc pixels (the fixnum pixel-offset))) + + finally + ; + ; in place... + ; + (magick-set-image-pixels wand 0 0 columns rows storage$ 0 pixels) + (let ((reduction (max 1 (sqrt (/ (* columns rows) 200000))))) + (unless (= reduction 1) + (cells:trc "reduction factor!!!!!!!" reduction) + (setf columns (round columns reduction) rows (round rows reduction)) + (setf (image-size self) (cons columns rows)) + (magick-resize-image wand columns rows cubic-filter 0) + (wand-images-write wand (image-path self)))) + ; + ; flopped... + ; + (let ((cw (clone-magick-wand wand))) + (magick-set-image-type cw (magick-get-image-type wand)) + (magick-get-image-pixels wand 0 0 columns rows storage$ 0 pixels ) ;; get resized pixels + (let ((e (magick-set-image-pixels cw 0 0 columns rows storage$ 0 pixels))) + (unless (zerop e) + (cells:trc "Error setting pixels!!!!!!!!" e))) + + (magick-flop-image cw) + (wand-images-write cw (merge-pathnames (conc$ (pathname-name (image-path self)) "-flop") + (image-path self))) + (cells:trc "local magick" (list columns rows) + (list (magick-get-image-width wand) + (magick-get-image-height wand))))))) + (values pixels columns rows)))) --- /project/cello/cvsroot/cello/cl-magick/wand-pixels.lisp 2006/08/21 04:28:28 1.3 +++ /project/cello/cvsroot/cello/cl-magick/wand-pixels.lisp 2007/02/02 20:11:09 1.4 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -26,9 +26,10 @@ ((pixels :initarg :pixels :accessor pixels :initform nil))) (defmethod initialize-instance :after ((self wand-pixels) &key) - (when (and (mgk-wand self) (eql :input (direction self))) + (when (and (mgk-wand self) (eql :input (wand-direction self))) (magick-flip-image (mgk-wand self)) - (setf (pixels self) (wand-get-image-pixels (mgk-wand self))))) + (cells::trc "getting pixels for" (image-path self)) + (setf (pixels self) (wand-get-image-pixels self)))) (defmethod wand-release :after ((wand wand-pixels)) (when (pixels wand) @@ -46,7 +47,7 @@ (let ((y-move (downs (+ 0 (abs (- top bottom)))))) (with-bitmap-shifted (0 y-move) (cells:trc nil "wand-render pixels move" 0 y-move :top top :bottom bottom) - + (if (ogl-get-boolean gl_current_raster_position_valid) (progn #+shh (format t "~&rasterpos ~a OK: ~a" @@ -55,7 +56,7 @@ (ogl-raster-pos-get) self )) #+wait (gl-pixel-zoom (/ (- right left) (car sz)) (/ (abs (- top bottom)) (cdr sz))) - #+not (print (list "draw pixels sz, lbox" left right (file-path$ self) sz + #+not (print (list "draw pixels sz, lbox" left right (image-path self) sz :tby top bottom y-move)) #+shh (unless (zerop (gl-is-enabled gl_scissor_test)) @@ -67,13 +68,18 @@ ;(gl-scalef 1000 1000 1000) ;(gl-disable gl_scissor_test) ;; debugging try (gl-enable gl_blend) ;; debugging try - (gl-blend-func gl_src_alpha gl_one) - (gl-blend-func gl_dst_alpha gl_one_minus_src_alpha) + ;(gl-blend-func gl_src_alpha gl_one) + ;(gl-blend-func gl_dst_alpha gl_one_minus_src_alpha) + (gl-blend-func gl_src_alpha gl_one_minus_src_alpha) ;;(cells:trc "drew pixels " gl_src_alpha gl_zero) (gl-polygon-mode gl_front_and_back gl_fill) #+not (cells:trc nil "wand-pixelling" (ogl-raster-pos-get)) (gl-pixel-storei gl_unpack_alignment 1) - (gl-draw-pixels (+ (car sz) 0) (cdr sz) - gl_rgb gl_unsigned_byte (pixels self)) - (ogl::glec :draw-pixels)))) \ No newline at end of file + (storage self) gl_unsigned_byte (pixels self)) + (ogl::gl-pixel-transferf gl_alpha_scale 1) + (ogl::glec :draw-pixels)))) + + + + --- /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/10/13 05:57:27 1.8 +++ /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2007/02/02 20:11:10 1.9 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -37,23 +37,33 @@ (defmethod texture-name :around ((self wand-texture)) (or (call-next-method) - (let* ((trunc-sz (cons (expt 2 (floor (log (car (image-size self)) 2))) - (expt 2 (floor (log (cdr (image-size self)) 2))))) - (grow-sz (cons (expt 2 (ceiling (log (car (image-size self)) 2))) - (expt 2 (ceiling (log (cdr (image-size self)) 2))))) - (best-fit-sz (best-fit-cons trunc-sz (image-size self) grow-sz))) - ;;(print `(texture-name> gennning texture ,self)) ;; frgo: debug... - (unless (equal (image-size self) best-fit-sz) - ;;(print `(texture-name> tex-refit ,(image-size self) to ,best-fit-sz)) ;; frgo: debug... - (magick-scale-image (mgk-wand self) (car best-fit-sz) (cdr best-fit-sz)) -;;; gaussian-filter 0) - (setf (image-size self) best-fit-sz)) - - ;;(print `(texture-name> new image size , self ,(image-size self))) ;; frgo: debug... - (let ((tx (wand-image-to-texture self))) - (if (plusp tx) - (setf (texture-name self) tx) - (break "bad tx name ~a for ~a" tx self)))))) + (let ((tx (wand-image-to-texture self))) + (if (plusp tx) + (setf (texture-name self) tx) + (break "bad tx name ~a for ~a" tx self))))) + +;;; +;;; this next stuff converts image to 2^n dimensions and may still be necessary +;;; on older graphics cards. /// test for this on old or lame PCs +;;; +;;; (let* ((trunc-sz (cons (expt 2 (floor (log (car (image-size self)) 2))) +;;; (expt 2 (floor (log (cdr (image-size self)) 2))))) +;;; (grow-sz (cons (expt 2 (ceiling (log (car (image-size self)) 2))) +;;; (expt 2 (ceiling (log (cdr (image-size self)) 2))))) +;;; (best-fit-sz (best-fit-cons trunc-sz (image-size self) grow-sz))) +;;; ;;(print `(texture-name> gennning texture ,self)) ;; frgo: debug... +;;; +;;; (unless t ;; (equal (image-size self) best-fit-sz) +;;; ;(print `(texture-name> tex-refit ,(image-size self) to ,best-fit-sz)) +;;; (magick-scale-image (mgk-wand self) (car best-fit-sz) (cdr best-fit-sz)) +;;; ;;; gaussian-filter 0) +;;; (setf (image-size self) best-fit-sz)) +;;; +;;; ;;(print `(texture-name> new image size , self ,(image-size self))) ;; frgo: debug... +;;; (let ((tx (wand-image-to-texture self))) +;;; (if (plusp tx) +;;; (setf (texture-name self) tx) +;;; (break "bad tx name ~a for ~a" tx self)))))) (defun wand-texture-activate (wand) @@ -63,11 +73,9 @@ (defparameter *textures-1* (fgn-alloc 'kt-opengl::gluint 1 :ignore)) (defun wand-image-to-texture (self) - (let ((tx (ogl-texture-gen) #+not (progn (gl-gen-textures 1 *textures-1*) - (ff-elt *textures-1* gluint 0))) - (pixels (wand-get-image-pixels (mgk-wand self) 0 0 - (car (image-size self)) - (cdr (image-size self))))) + ;;(cells::trcx wand-image-to-texture (image-path self)) + (let ((tx (ogl-texture-gen)) + (pixels (wand-get-image-pixels self))) ;;(assert (not *ogl-listing-p*)) (assert (plusp tx)) (cells:trc nil "!!!!wand-image-to-texture genning new tx: ~a" tx) ;; frgo: debug... @@ -82,30 +90,50 @@ (gl-pixel-storei gl_pack_alignment 1 ) (gl-pixel-storei gl_unpack_alignment 1 ) - - (gllog :texture tx (* 3 (car (image-size self)) (cdr (image-size self))) :wim2tex) - (gl-tex-image2d gl_texture_2d 0 3 (car (image-size self)) (cdr (image-size self)) - 0 gl_rgb gl_unsigned_byte pixels) + + (gl-tex-image2d gl_texture_2d 0 gl_rgba (car (image-size self)) (cdr (image-size self)) + 0 (storage self) gl_unsigned_byte pixels) (kt-opengl::glec :tex-image) + ;;(print `(wand-image-to-texture loaded texture sized ,(image-size self))) ;; frgo: debug... (fgn-free pixels) tx)) + +#| + +To avoid changing the texture, use GL_MODULATE mode (glTexEnv) +and use glColor4f (1.0, 1.0, 1.0, alpha). + +This multiplies 'alpha' by the alpha in the RGBA texture map +before blending into the frame buffer. The constants you mentioned +are for that later blending stage. + +|# (defmethod wand-render ((self wand-texture) left top right bottom &aux (sz (image-size self))) - #+not (cells:trc nil "wand-render tex-name:" (texture-name self) (tile-p self) self + #+not (cells:trc nil "wand-render tex-name:" (texture-name self) (tilep self) self :size sz :bbox (list left top right bottom)) - (with-attrib (gl_texture_bit) ;; gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) + (with-attrib (gl_texture_bit gl_color_buffer_bit) ;; gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) (wand-texture-activate self) - #+slower - (ogl-tex-gen-setup gl_object_linear gl_modulate - (if (tile-p self) gl_repeat gl_clamp) + + (gl-enable gl_blend) + (gl-blend-func gl_src_alpha gl_one_minus_src_alpha) + + (gl-enable gl_alpha_test) + (gl-alpha-func gl_greater 0.0) + + #+not + (progn + (ogl-tex-gen-setup gl_object_linear gl_modulate + (if (tilep self) gl_repeat gl_clamp) (/ 1 (max (car sz)(cdr sz))) :s :tee :r) - - (if (tile-p self) + (gl-rectf left top right bottom)) + + (if (tilep self) (with-gl-begun (gl_quads) (loop for y from top above bottom by (cdr sz) for y-rem = (- bottom y) From ktilton at common-lisp.net Fri Feb 2 20:11:17 2007 From: ktilton at common-lisp.net (ktilton) Date: Fri, 2 Feb 2007 15:11:17 -0500 (EST) Subject: [cello-cvs] CVS cello/cl-openal Message-ID: <20070202201117.7646236012@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv2070/cl-openal Modified Files: cl-openal-init.lisp cl-openal.asd cl-openal.lisp cl-openal.lpr wav-handling.lisp Log Message: --- /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/11/13 05:29:28 1.8 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2007/02/02 20:11:14 1.9 @@ -2,7 +2,7 @@ ;;________________________________________________________ ;; ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -34,12 +34,12 @@ (when (and *openal-initialized-p* (not force)) (return-from cl-openal-init t)) -#-macosx (xoa) +#-cffi-features:darwin (xoa) (assert (use-foreign-library OpenAL) () "Failed to load OpenAL dynamic lib") -#-macosx +#-cffi-features:darwin (assert (use-foreign-library ALut) () "Failed to load alut dynamic lib") @@ -56,7 +56,7 @@ (format t "got openal device ~a" device) - (let* ((context (alc-create-context device 0))) + (let* ((context (alc-create-context device (null-pointer)))) (when (null-pointer-p context) (break "~&Failed to create Open AL context")) (format t "~&created openal context ~a" context) @@ -87,7 +87,7 @@ (let ((context (alc-get-current-context))) (unless (null-pointer-p context) (let ((device (alc-get-contexts-device context))) - (alc-make-context-current 0) + (alc-make-context-current (null-pointer)) (alc-destroy-context context) (alc-close-device device) (setf *openal-initialized-p* nil)))))) --- /project/cello/cvsroot/cello/cl-openal/cl-openal.asd 2006/07/06 22:09:11 1.2 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.asd 2007/02/02 20:11:14 1.3 @@ -16,7 +16,7 @@ :licence "MIT" :description "Partial OpenAL Bindings" :long-description "Poorly implemented bindings to half of OpenAL" - :depends-on (cffi cffi-extender) + :depends-on (cffi cffi-extender cells) :perform (load-op :after (op cl-openal) (pushnew :cl-openal cl:*features*)) :components ((:file "cl-openal") --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2006/11/13 05:29:28 1.5 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2007/02/02 20:11:14 1.6 @@ -2,7 +2,7 @@ ;;________________________________________________________ ;; ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -22,7 +22,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: cl-openal.lisp,v 1.5 2006/11/13 05:29:28 ktilton Exp $ +;;; $Id: cl-openal.lisp,v 1.6 2007/02/02 20:11:14 ktilton Exp $ (pushnew :cl-openal *features*) @@ -70,3 +70,5 @@ (print `(unloading foreign library ,dll)) (ff:unload-foreign-library dll)))) +#-allegro +(defun xoa ()) --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/11/13 05:29:28 1.11 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2007/02/02 20:11:14 1.12 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/cl-openal/wav-handling.lisp 2006/11/13 05:29:28 1.4 +++ /project/cello/cvsroot/cello/cl-openal/wav-handling.lisp 2007/02/02 20:11:14 1.5 @@ -2,7 +2,7 @@ ;;________________________________________________________ ;; ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal From ktilton at common-lisp.net Fri Feb 2 20:11:22 2007 From: ktilton at common-lisp.net (ktilton) Date: Fri, 2 Feb 2007 15:11:22 -0500 (EST) Subject: [cello-cvs] CVS cello/kt-opengl Message-ID: <20070202201122.8D9AC3C010@common-lisp.net> Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv2070/kt-opengl Modified Files: colors.lisp defpackage.lisp gl-constants.lisp gl-def.lisp gl-functions.lisp glu-functions.lisp kt-opengl-config.lisp kt-opengl.lisp kt-opengl.lpr ogl-macros.lisp ogl-utils.lisp Log Message: --- /project/cello/cvsroot/cello/kt-opengl/colors.lisp 2006/11/13 05:29:31 1.8 +++ /project/cello/cvsroot/cello/kt-opengl/colors.lisp 2007/02/02 20:11:17 1.9 @@ -1,6 +1,6 @@ ;;; -*- mode: Lisp; Syntax: Common-Lisp; Package: kt-opengl; -*- ;;; -;;; Copyright ? 2006 by Kenneth William Tilton +;;; Copyright (c) 2006 by Kenneth William Tilton ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a ;;; copy of this software and associated documentation files (the "Software"), @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; -;;; $Id: colors.lisp,v 1.8 2006/11/13 05:29:31 ktilton Exp $ +;;; $Id: colors.lisp,v 1.9 2007/02/02 20:11:17 ktilton Exp $ (in-package #:kt-opengl) @@ -33,12 +33,13 @@ (g 0 ) (b 0 )) -(defstruct rgba (r 0.0f0) - (g 0.0f0) - (b 0.0f0) - (a 1.0f0) - (fo 0) ;; fo = foreign ptr address - (id nil)) +(defstruct rgba + (r 0.0f0) + (g 0.0f0) + (b 0.0f0) + (a 1.0f0) + (fo 0) ;; fo = foreign ptr address + (id nil)) (defparameter *known-colors* '() "Known colors, safed as cons of color-name and rgba-color struct.") @@ -90,7 +91,14 @@ (defmacro define-ogl-rgba-color (color-name red green blue alpha) `(let ((rgba-color (mk-rgba ,red ,green ,blue ,alpha ',color-name))) (prog1 - (defconstant ,color-name rgba-color) + ;; Possibly due to aggressive compile settings, OpenMCL will try + ;; to inline these constants and fail because there's no + ;; appropriate MAKE-LOAD-FORM method. I'm not sure whether + ;; inlining it is a good idea because the RGBA-COLOR structure + ;; contains a foreign pointer. So, for now, let's avoid inlining + ;; instead of writing a MAKE-LOAD-FORM method for this + ;; structure. --luis + (#-openmcl defconstant #+openmcl defparameter ,color-name rgba-color) (pushnew rgba-color *known-colors*) (utils-kt::export! ,color-name)))) --- /project/cello/cvsroot/cello/kt-opengl/defpackage.lisp 2006/10/01 20:45:04 1.2 +++ /project/cello/cvsroot/cello/kt-opengl/defpackage.lisp 2007/02/02 20:11:18 1.3 @@ -1,6 +1,6 @@ ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: defpackage.lisp,v 1.2 2006/10/01 20:45:04 fgoenninger Exp $ +;;; $Id: defpackage.lisp,v 1.3 2007/02/02 20:11:18 ktilton Exp $ (pushnew :kt-opengl *features*) --- /project/cello/cvsroot/cello/kt-opengl/gl-constants.lisp 2006/07/03 00:35:15 1.2 +++ /project/cello/cvsroot/cello/kt-opengl/gl-constants.lisp 2007/02/02 20:11:18 1.3 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: kt-opengl; -*- ;;; -;;; Copyright ? 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/kt-opengl/gl-def.lisp 2006/08/28 21:45:27 1.3 +++ /project/cello/cvsroot/cello/kt-opengl/gl-def.lisp 2007/02/02 20:11:18 1.4 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: kt-opengl; -*- ;;; -;;; Copyright ? 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/kt-opengl/gl-functions.lisp 2006/08/28 21:45:27 1.4 +++ /project/cello/cvsroot/cello/kt-opengl/gl-functions.lisp 2007/02/02 20:11:19 1.5 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: kt-opengl; -*- ;;; -;;; Copyright ? 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/kt-opengl/glu-functions.lisp 2006/08/28 21:45:27 1.3 +++ /project/cello/cvsroot/cello/kt-opengl/glu-functions.lisp 2007/02/02 20:11:19 1.4 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: kt-opengl; -*- ;;; -;;; Copyright ? 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl-config.lisp 2006/10/01 12:28:20 1.1 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl-config.lisp 2007/02/02 20:11:19 1.2 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/10/13 05:57:28 1.11 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2007/02/02 20:11:19 1.12 @@ -1,7 +1,7 @@ ;;________________________________________________________ ;; ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -21,11 +21,10 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: kt-opengl.lisp,v 1.11 2006/10/13 05:57:28 ktilton Exp $ +;;; $Id: kt-opengl.lisp,v 1.12 2007/02/02 20:11:19 ktilton Exp $ (pushnew :kt-opengl *features*) - (in-package :kt-opengl) (defvar *selecting*) @@ -35,15 +34,15 @@ (defun kt-opengl-init () (unless *opengl-dll* (progn - (let ((opengl-loaded-p - (use-foreign-library OpenGL)) - (glu-loaded-p - #+macosx - t ;; on Mac OS X, no explicit loading of GLU needed. - #-macosx - (use-foreign-library GLU))) - (assert (and opengl-loaded-p glu-loaded-p)) - (setf *opengl-dll* t))))) + (let ((opengl-loaded-p + (use-foreign-library OpenGL)) + (glu-loaded-p + #+macosx + t ;; on Mac OS X, no explicit loading of GLU needed. + #-macosx + (use-foreign-library GLU))) + (assert (and opengl-loaded-p glu-loaded-p)) + (setf *opengl-dll* t))))) (defun kt-opengl-reset () (loop for ec = (glgeterror) --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/11/13 05:29:31 1.8 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2007/02/02 20:11:19 1.9 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/10/01 20:42:51 1.10 +++ /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2007/02/02 20:11:19 1.11 @@ -2,7 +2,7 @@ ;;________________________________________________________ ;; ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal --- /project/cello/cvsroot/cello/kt-opengl/ogl-utils.lisp 2006/10/02 03:55:23 1.9 +++ /project/cello/cvsroot/cello/kt-opengl/ogl-utils.lisp 2007/02/02 20:11:19 1.10 @@ -2,7 +2,7 @@ ;;________________________________________________________ ;; ;;; -;;; Copyright ? 2004 by Kenneth William Tilton. +;;; Copyright (c) 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -22,7 +22,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: ogl-utils.lisp,v 1.9 2006/10/02 03:55:23 ktilton Exp $ +;;; $Id: ogl-utils.lisp,v 1.10 2007/02/02 20:11:19 ktilton Exp $ (declaim (optimize (debug 1) (speed 3) (safety 1) (compilation-speed 0))) @@ -42,19 +42,19 @@ ;;; =========================================================================== (defstruct v3i - (x :type GLint) - (y :type GLint) - (z :type GLint)) + (x 0 :type GLint) + (y 0 :type GLint) + (z 0 :type GLint)) (defstruct v3f - (x :type GLfloat) - (y :type GLfloat) - (z :type GLfloat)) + (x 0.0s0 :type GLfloat) + (y 0.0s0 :type GLfloat) + (z 0.0s0 :type GLfloat)) (defstruct v3d - (x :type GLdouble) - (y :type GLdouble) - (z :type GLdouble)) + (x 0.0d0 :type GLdouble) + (y 0.0d0 :type GLdouble) + (z 0.0d0 :type GLdouble)) ;;; =========================================================================== ;;; FUNCTIONS