[cello-cvs] CVS cello
ktilton
ktilton at common-lisp.net
Sat May 27 06:01:38 UTC 2006
Update of /project/cello/cvsroot/cello
In directory clnet:/tmp/cvs-serv7090
Added Files:
NeHe-06.lpr nehe-06.lisp nehe-14x.lisp
Log Message:
--- /project/cello/cvsroot/cello/NeHe-06.lpr 2006/05/27 06:01:38 NONE
+++ /project/cello/cvsroot/cello/NeHe-06.lpr 2006/05/27 06:01:38 1.1
;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*-
(in-package :cg-user)
(defpackage :NEHE-06)
(define-project :name :nehe-06
:modules (list (make-instance 'module :name "nehe-06.lisp")
(make-instance 'module :name "nehe-14x.lisp"))
:projects (list (make-instance 'project-module :name
"..\\Celtk\\CELTK")
(make-instance 'project-module :name
"cffi-extender\\cffi-extender")
(make-instance 'project-module :name
"kt-opengl\\kt-opengl")
(make-instance 'project-module :name
"cl-magick\\cl-magick")
(make-instance 'project-module :name
"cl-ftgl\\cl-ftgl")
(make-instance 'project-module :name
"cl-openal\\cl-openal"))
:libraries nil
:distributed-files nil
:internally-loaded-files nil
:project-package-name :nehe-06
:main-form nil
:compilation-unit t
:verbose nil
:runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane
:cg.bitmap-pane.clipboard :cg.bitmap-stream
:cg.button :cg.caret :cg.check-box :cg.choice-list
:cg.choose-printer :cg.clipboard
:cg.clipboard-stack :cg.clipboard.pixmap
:cg.color-dialog :cg.combo-box :cg.common-control
:cg.comtab :cg.cursor-pixmap :cg.curve
:cg.dialog-item :cg.directory-dialog
:cg.directory-dialog-os :cg.drag-and-drop
:cg.drag-and-drop-image :cg.drawable
:cg.drawable.clipboard :cg.dropping-outline
:cg.edit-in-place :cg.editable-text
:cg.file-dialog :cg.fill-texture
:cg.find-string-dialog :cg.font-dialog
:cg.gesture-emulation :cg.get-pixmap
:cg.get-position :cg.graphics-context
:cg.grid-widget :cg.grid-widget.drag-and-drop
:cg.group-box :cg.header-control :cg.hotspot
:cg.html-dialog :cg.html-widget :cg.icon
:cg.icon-pixmap :cg.ie :cg.item-list
:cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu
:cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget
:cg.list-view :cg.mci :cg.menu :cg.menu.tooltip
:cg.message-dialog :cg.multi-line-editable-text
:cg.multi-line-lisp-text :cg.multi-picture-button
:cg.multi-picture-button.drag-and-drop
:cg.multi-picture-button.tooltip :cg.ocx
:cg.os-widget :cg.os-window :cg.outline
:cg.outline.drag-and-drop
:cg.outline.edit-in-place :cg.palette
:cg.paren-matching :cg.picture-widget
:cg.picture-widget.palette :cg.pixmap
:cg.pixmap-widget :cg.pixmap.file-io
:cg.pixmap.printing :cg.pixmap.rotate :cg.printing
:cg.progress-indicator :cg.project-window
:cg.property :cg.radio-button :cg.rich-edit
:cg.rich-edit-pane :cg.rich-edit-pane.clipboard
:cg.rich-edit-pane.printing :cg.sample-file-menu
:cg.scaling-stream :cg.scroll-bar
:cg.scroll-bar-mixin :cg.selected-object
:cg.shortcut-menu :cg.static-text :cg.status-bar
:cg.string-dialog :cg.tab-control
:cg.template-string :cg.text-edit-pane
:cg.text-edit-pane.file-io :cg.text-edit-pane.mark
:cg.text-or-combo :cg.text-widget :cg.timer
:cg.toggling-widget :cg.toolbar :cg.tooltip
:cg.trackbar :cg.tray :cg.up-down-control
:cg.utility-dialog :cg.web-browser
:cg.web-browser.dde :cg.wrap-string
:cg.yes-no-list :cg.yes-no-string :dde)
:splash-file-module (make-instance 'build-module :name "")
:icon-file-module (make-instance 'build-module :name "")
:include-flags '(:top-level :debugger)
:build-flags '(:allow-runtime-debug :purify)
:autoload-warning t
:full-recompile-for-runtime-conditionalizations nil
:default-command-line-arguments "+M +t \"Console for Debugging\""
:additional-build-lisp-image-arguments '(:read-init-files nil)
:old-space-size 256000
:new-space-size 6144
:runtime-build-option :standard
:on-initialization 'nehe-06::nehe-06
:on-restart 'do-default-restart)
;; End of Project Definition
--- /project/cello/cvsroot/cello/nehe-06.lisp 2006/05/27 06:01:38 NONE
+++ /project/cello/cvsroot/cello/nehe-06.lisp 2006/05/27 06:01:38 1.1
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;; nehe-06.lisp --- Celtk/Togl version of cl-opengl Lisp version of
;;; nehe lesson 06 spinning cube with texture
;;;
(defpackage :nehe-06
(:use :common-lisp :utils-kt :cells :celtk :kt-opengl :cl-magick ))
(in-package :nehe-06)
(defvar *startx*)
(defvar *starty*)
(defvar *xangle0*)
(defvar *yangle0*)
(defvar *xangle*)
(defvar *yangle*)
(defparameter *vTime* 100)
(defparameter *grace* nil)
(defconstant wcx 640) ;; Window Width
(defconstant wcy 480) ;; Window Height
(defparameter xrot 0.0f0)
(defparameter yrot 0.0f0)
(defparameter zrot 0.0f0)
(defparameter *skin6* nil)
(defun nehe-06 () ;; ACL project manager needs a zero-argument function, in project package
(setf ogl::*gl-begun* nil)
(test-window 'nehe-06-demo))
(defmodel nehe-06-demo (window)
()
(:default-initargs
:title$ "Rotating nehe-06 Widget Test"
:kids (c? (the-kids
(mk-stack (:packing (c?pack-self))
(make-instance 'nehe06
:fm-parent *parent*
:width 400 :height 400
:timer-interval 2 #+later (c? (let ((n$ (md-value (fm-other :vtime))))
(format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0)))))
:double 1 ;; "yes"
))))))
(defconstant +pif+ (coerce pi 'single-float))
(defmodel nehe06 (togl)
((shoot-me :cell nil :initform nil :accessor shoot-me)
(frame-count :cell nil :initform 0 :accessor frame-count)
(t0 :cell nil :initform 0 :accessor t0)
;
(width :initarg :wdith :initform 400 :accessor width)
(height :initarg :wdith :initform 400 :accessor height))
(:default-initargs
:cb-destroy (lambda (self)
(bwhen (s (shoot-me self))
(trc "stopping source" s)
(cl-openal::al-source-stop s)))))
(defmethod togl-timer-using-class ((self nehe06))
(trc nil "enter nehe-06 timer" self (togl-ptr self) (get-internal-real-time))
(Togl_PostRedisplay (togl-ptr self))
(if (shoot-me self)
(unless (cl-openal::al-source-playing-p (shoot-me self))
(cl-openal::al-source-play (shoot-me self)))
(setf (shoot-me self)
(cl-openal::wav-play-start "/0dev/cello/user/sounds/spinning.wav"))))
(defmethod togl-reshape-using-class ((self nehe06))
(let ((width (Togl_width (togl-ptr self)))
(height (Togl_height (togl-ptr self))))
(trc "enter nh6 reshape" self width height)
(unless (or (zerop width) (zerop height))
(gl-viewport 0 0 width height)
(gl-matrix-mode gl_projection)
(gl-load-identity)
(glu-perspective 45 (/ width height) 0.1 100)
(gl-matrix-mode gl_modelview)
(gl-load-identity))))
(defparameter *jmc-font* (ftgl-make :texture 'sylfaen 48 96 18))
(defmethod togl-display-using-class ((self nehe06))
(gl-load-identity)
(gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit))
(gl-line-width 1)
(gl-color3f 1f0 1f0 1f0)
(gl-translatef 0 0 -5)
(gl-enable gl_texture_2d)
;--------------------------------------------
(progn
;; (gl-translatef 0 0 -5)
(let ((f 0.2))
(gl-rotatef (incf xrot (* f 3)) 1 0 0)
(gl-rotatef (incf yrot (* f 2)) 0 1 0)
(gl-rotatef (incf zrot (* f 4)) 0 0 1))
(wand-texture-activate *skin6*)
(flet ((v3f (x y z)
(let ((scale 1))
(gl-vertex3f (* scale x)(* scale y)(* scale z)))))
(with-gl-begun (gl_quads)
;; Front Face
(gl-tex-coord2f 0 1)(v3f 1 -1 1)
(gl-tex-coord2f 0 0)(v3f 1 1 1)
(gl-tex-coord2f 1 0)(v3f -1 1 1)
(gl-tex-coord2f 1 1)(v3f -1 -1 1)
;;; (gl-tex-coord2f 1 0)(v3f 1 -1 1)
;;; (gl-tex-coord2f 1 1)(v3f 1 1 1)
;;; (gl-tex-coord2f 0 1)(v3f -1 1 1)
;;; (gl-tex-coord2f 0 0)(v3f -1 -1 1)
;; Back Face
(gl-tex-coord2f 1 0) (v3f -1 -1 -1)
(gl-tex-coord2f 1 1) (v3f -1 1 -1)
(gl-tex-coord2f 0 1) (v3f 1 1 -1)
(gl-tex-coord2f 0 0) (v3f 1 -1 -1)
;;; Top Face
(gl-tex-coord2f 0 1) (v3f -1 1 -1)
(gl-tex-coord2f 0 0) (v3f -1 1 1)
(gl-tex-coord2f 1 0) (v3f 1 1 1)
(gl-tex-coord2f 1 1) (v3f 1 1 -1)
;;; Bottom Face
(gl-tex-coord2f 1 1) (v3f -1 -1 -1)
(gl-tex-coord2f 0 1) (v3f 1 -1 -1)
(gl-tex-coord2f 0 0) (v3f 1 -1 1)
(gl-tex-coord2f 1 0) (v3f -1 -1 1)
;;; Right face
(gl-tex-coord2f 1 0) (v3f 1 -1 -1)
(gl-tex-coord2f 1 1) (v3f 1 1 -1)
(gl-tex-coord2f 0 1) (v3f 1 1 1)
(gl-tex-coord2f 0 0) (v3f 1 -1 1)
;;; Left Face
(gl-tex-coord2f 0 0) (v3f -1 -1 -1)
(gl-tex-coord2f 1 0) (v3f -1 -1 1)
(gl-tex-coord2f 1 1) (v3f -1 1 1)
(gl-tex-coord2f 0 1) (v3f -1 1 -1)
))
#+ifuwanttoseepixmap
(wand-render *grace* 0 0 1 -1)
(progn
(gl-scalef 0.006 0.006 0.0)
(gl-disable gl_lighting)
(gl-translatef -250 -300 -100)
(gl-enable gl_texture_2d)
(loop repeat 4 do
(ftgl-render *jmc-font* "Dr. John McCarthy")
(gl-rotatef 90 0 0 1))
(gl-translatef 100 200 100)
)
)
(Togl_SwapBuffers (togl-ptr self))
#+shhh (print-frame-rate self))
(defmethod togl-create-using-class ((self nehe06))
(gl-enable gl_texture_2d)
(gl-shade-model gl_smooth)
(gl-clear-color 0 0 0 1)
(gl-clear-depth 1)
(gl-enable gl_depth_test)
(gl-depth-func gl_lequal)
(gl-hint gl_perspective_correction_hint gl_nicest)
(setf *skin6* (mgk:wand-ensure-typed 'wand-texture
(test-image "jmcbw512" "jpg")))
(setf *grace* (mgk:wand-ensure-typed 'wand-pixels
(test-image "turing" "gif"))))
(defun print-frame-rate (window)
(with-slots (frame-count t0) window
(incf frame-count)
(let ((time (get-internal-real-time)))
(when (= t0 0)
(setq t0 time))
(when (>= (- time t0) (* 5 internal-time-units-per-second))
(let* ((seconds (/ (- time t0) internal-time-units-per-second))
(fps (/ frame-count seconds)))
(declare (ignorable fps))
#+shh (format *terminal-io* "~D frames in ~3,1F seconds = ~6,3F FPS~%"
frame-count seconds fps))
(setq t0 time)
(setq frame-count 0)))))
(defun test-image (filename filetype)
(make-pathname
:directory '(:absolute "0dev" "user" "graphics" "shapers")
:name (string filename)
:type (string filetype)))
--- /project/cello/cvsroot/cello/nehe-14x.lisp 2006/05/27 06:01:38 NONE
+++ /project/cello/cvsroot/cello/nehe-14x.lisp 2006/05/27 06:01:38 1.1
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;; nehe-14.lisp --- Celtk/Togl version of
;;; nehe lesson 14 spinning text string
;;;
(defpackage :nehe-06
(:use :common-lisp :utils-kt :cells :celtk :kt-opengl :cl-ftgl))
(in-package :nehe-06)
(defparameter g_rot 0.0f0)
(defvar *frames*)
(defvar *start*)
(defvar *test-fonts*)
(defun test-font (mode)
(cdr (assoc mode *test-fonts*)))
#+test
(nehe-14)
(defun nehe-14 () ;; ACL project manager needs a zero-argument function, in project package
(setf ogl::*gl-begun* nil)
(setq *test-fonts*
(mapcar (lambda (mode)
(cons mode (ftgl-make mode *gui-style-default-face* 48 96 18)))
'(:texture :pixmap :bitmap :outline :polygon :extruded)))
(test-window 'nehe-14-demo))
(defmodel nehe-14-demo (window)
()
(:default-initargs
:title$ "NeHe's OpenGL Framework"
:kids (c? (the-kids
(mk-stack (:packing (c?pack-self))
(make-instance 'nehe14
:fm-parent *parent*
:width 400 :height 400
:timer-interval 1 #+later (c? (let ((n$ (md-value (fm-other :vtime))))
(format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0)))))
:double 1 ;; "yes"
))))))
(defmodel nehe14 (togl)
((frame-count :cell nil :initform 0 :accessor frame-count)
(t0 :cell nil :initform 0 :accessor t0)
;
(width :initarg :wdith :initform 640 :accessor width)
(height :initarg :wdith :initform 400 :accessor height)))
(defmethod togl-timer-using-class ((self nehe14))
(trc nil "enter nehe-14 timer" self (togl-ptr self) (get-internal-real-time))
(Togl_PostRedisplay (togl-ptr self)))
(defmethod togl-reshape-using-class ((self nehe14))
(let ((width (Togl_width (togl-ptr self)))
(height (Togl_height (togl-ptr self))))
(trc "reshape" width height)
(unless (or (zerop width) (zerop height))
(trc "reshape" width height)
(gl-viewport 0 0 width height)
(gl-matrix-mode gl_projection)
(gl-load-identity)
(glu-perspective 70 1 1 1000)
(glu-look-at 0d0 0d0 5d0 0d0 0d0 0d0 0d0 1d0 0d0)
(gl-matrix-mode gl_modelview)
(gl-load-identity)
(gl-clear-depth 1d0))))
(defmethod togl-display-using-class ((self nehe14))
(incf *frames*)
(gl-load-identity) ;; Reset The Current Modelview Matrix
(gl-clear-color 0 0 0 1)
(gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit))
(gl-translatef 0.0f0 0.0f0 2.0f0) ;; Move Into The Screen
;; Pulsing Colors Based On The Rotation
(gl-color3f (* 1.0f0 (cos (/ g_rot 20.0f0)))
(* 1.0f0 (sin (/ g_rot 25.0f0)))
(- 1.0f0 (* 0.5f0 (cos (/ g_rot 17.0f0)))))
(gl-scalef 0.006 0.006 0.0)
(gl-disable gl_lighting)
(gl-translatef -100 -200 0)
(gl-enable gl_texture_2d)
(ftgl-render (test-font :texture)
(format nil "texture ~d" (floor (/ *frames*
(max 1 (- (now) *start*))))))
(gl-translatef 100 200 0)
(gl-translatef -100 200 0)
(gl-line-width 3)
(ftgl-render (test-font :outline) "un-rotated outline")
(gl-translatef 100 -200 0)
(gl-translatef -200 100 0)
(ftgl-render (test-font :polygon) "un-rotated polygon")
(gl-translatef 200 -100 0)
(with-matrix ()
(gl-polygon-mode gl_front_and_back gl_line)
(gl-rotatef g_rot 1.0f0 0.5f0 0.0f0)
(gl-scalef 4 4 4)
(gl-translatef -70 -20 0)
(ftgl-render (test-font :extruded) "NeHe")
(gl-polygon-mode gl_front_and_back gl_fill)
)
[103 lines skipped]
More information about the Cello-cvs
mailing list