cello-cvs
Threads by month
- ----- 2025 -----
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2007 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2006 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2005 -----
- December
- November
- October
- September
- August
- July
- June
- May
February 2007
- 1 participants
- 7 discussions
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
1
0
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
1
0
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)
1
0
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.
1
0
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)
1
0
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))
+ ,@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))
,@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 (,@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)
1
0
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
1
0