Commit 2b516383 authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Moved pgl to its own directory.

parent ffa0734c
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: com.informatimago.clext.pgl.asd
;;;;FILE: com.informatimago.pgl.asd
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; ASD file to load the com.informatimago.clext.pgl library.
;;;; ASD file to load the com.informatimago.pgl library.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
......@@ -33,7 +33,7 @@
;;;;**************************************************************************
(asdf:defsystem "com.informatimago.clext.pgl"
(asdf:defsystem "com.informatimago.pgl"
;; system attributes:
:description "Portable Graphics Library (Stanford Portable Library)"
:long-description "
......@@ -51,7 +51,7 @@ https://github.com/cs50/spl
:version "1.0.0"
:properties ((#:author-email . "pjb@informatimago.com")
(#:date . "Automn 2015")
((#:albert #:output-dir) . "/tmp/documentation/com.informatimago.clext/")
((#:albert #:output-dir) . "/tmp/documentation/com.informatimago/")
((#:albert #:formats) . ("docbook"))
((#:albert #:docbook #:template) . "book")
((#:albert #:docbook #:bgcolor) . "white")
......@@ -60,7 +60,7 @@ https://github.com/cs50/spl
"parse-number"
"com.informatimago.common-lisp.cesarum")
:components ((:file "pgl" :depends-on ()))
#+adsf3 :in-order-to #+adsf3 ((asdf:test-op (asdf:test-op "com.informatimago.clext.pgl.test")))
#+adsf3 :in-order-to #+adsf3 ((asdf:test-op (asdf:test-op "com.informatimago.pgl.test")))
#+asdf-unicode :encoding #+asdf-unicode :utf-8)
#-ccl (warn "Not yet completed on ~A" (lisp-implementation-type))
......
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: pgl-ball.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Test the pgl library with a bouncing ball.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2015-11-13 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2015
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(defpackage "COM.INFORMATIMAGO.PORTABLE-GRAPHICS-LIBRARY.TEST.BALL"
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.PORTABLE-GRAPHICS-LIBRARY")
(:export "RUN"))
(in-package "COM.INFORMATIMAGO.PORTABLE-GRAPHICS-LIBRARY.TEST.BALL")
(defclass ball (compound)
((vx :initarg :vx :accessor vx :initform (- (+ 10 (random 20.0d0)) 15))
(vy :initarg :vy :accessor vy :initform (- (+ 10 (random 30.0d0)) 15))
(gx :initarg :gx :accessor gx :initform 0 )
(gy :initarg :gy :accessor gy :initform (random 10.0d0) )))
(defun make-ball (diameter)
(let* ((components (cons (make-instance 'oval :x 0 :y 0 :width diameter :height diameter
:color *red* :fill-color *red* :filled t)
(loop :for alpha :from 0 :below 360 :by 30
:collect (make-instance 'arc
:x 0 :y 0
:width diameter :height diameter
:start alpha :sweep 15
:color *yellow* :fill-color *yellow* :filled t))))
(ball (make-instance 'ball :x 0 :y 0 :width diameter :height diameter
:components components
:vx (random 30.0d0) :vy 0
:gx 0 :gy (random 10.0d0))))
(dolist (component components) (send-to-front component))
ball))
(defun update-position-velocity (x vx gx w)
(incf x vx)
(unless (<= 0 x w)
(setf x (- x vx vx)
vx (* 0.9 (- vx))))
(incf vx gx)
(values x vx gx))
(defmethod update ((b ball) w h)
(let ((x (x b))
(y (y b))
(vx (vx b))
(vy (vy b))
(gx (gx b))
(gy (gy b))
(s (width b)))
(multiple-value-setq (x vx gx) (update-position-velocity x vx gx (- w s)))
(multiple-value-setq (y vy gy) (update-position-velocity y vy gy (- h s)))
(setf (vx b) vx
(vy b) vy
(gx b) gx
(gy b) gy)
(set-location b x y)))
(defclass ball-window (window)
((ball :initarg :ball :accessor ball)))
(defun make-ball-window ()
(let* ((w 512)
(h 342)
(ball (make-ball 80))
(background (make-instance 'compound
:x 0 :y 0 :width w :height h
:components (list (make-instance 'rect
:filled t :fill-color *blue* :color *blue*
:x 0 :y 0 :width w :height h)
ball))))
(make-instance
'ball-window
:ball ball
:title "Beach Ball"
:color *blue*
:x 20 :y 40
:width w :height h
:components (list background))))
(defmethod tick ((window ball-window))
(update (ball window) (width window) (height window)))
(defun run ()
(let ((w (make-ball-window))
(dt (make-instance 'timer :duration-ms 100)))
(start-timer dt)
(unwind-protect
(loop
:for e := (get-next-event (logior +timer-event+ +window-event+))
:do (case (event-type-keyword e)
(:timer-ticked (when (eql dt (event-timer e))
(tick w)))
(:window-closed (when (eql w (event-window e))
(loop-finish)))))
(stop-timer dt)
(free dt)
(close-window w))))
;;; THE END ;;;;
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: pgl-test.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Tests interactively the PGL.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2015-11-13 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2015 - 2015
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU Affero General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(in-package "PGL")
(defun test/string-escape ()
(assert (string= (string-escape (coerce #(#\bel #\bs #\page #\newline #\return #\tab #\vt #\" #\\) 'string))
"\"\\a\\b\\f\\n\\r\\t\\v\\042\\\\\""))
(assert (string= (string-unescape "\"\\a\\b\\f\\n\\r\\t\\v\\042\\\\\"")
(coerce #(#\bel #\bs #\page #\newline #\return #\tab #\vt #\" #\\) 'string)))
(assert (string= (string-escape "Hello\\ World\"!")
"\"Hello\\\\ World\\042!\""))
(assert (string= (string-unescape "\"Hello\\\\ World\\042!\"")
"Hello\\ World\"!"))
:success)
(defun test/scanner ()
(assert (equal (let ((s (make-scanner " hello(\"Howdy\", 42,-123.456e+78,false,true,foo)")))
(loop
:for token := (next-token s)
:while token :collect token))
'((symbol . "hello")
#\( "Howdy" #\, 42 #\, -1.2345600000000003D+80 #\,
(boolean) #\, (boolean . t) #\, (symbol . "foo") #\))))
:success)
(defun test/all ()
(test/string-escape)
(test/scanner))
(defun test-event-loop ()
(unwind-protect
(loop :for e := (get-next-event +any-event+)
:when e
:do (format *console-io* "~&~20,3F Got event ~A for window ~A~%"
(event-time e) (event-type-keyword e) (event-window e))
(case (event-type-keyword e)
(:window-closed (loop-finish))
(:window-resized)
(:last-window-closed (loop-finish))
(:action-performed
(scase (event-action-command e)
(("OK") (format *console-io* "~&Yay!~%"))
(("TEXT") (format *console-io* "~&Got text: ~S~%"
(text *t*)))
(otherwise (format *console-io* "~&Got action ~S~%"
(event-action-command e)))))
(:mouse-clicked)
(:mouse-pressed)
(:mouse-released)
(:mouse-moved)
(:mouse-dragged)
(:key-pressed)
(:key-released)
(:key-typed)
(:timer-ticked)))
(format *console-io* "~2%Test Event Loop Done.~2%")))
(defun make-test-window-1 ()
(let ((w 512)
(h 342))
(make-instance
'window
:x 20 :y 40
:width w :height h
:components (loop
:repeat 20
:collect (make-instance
(elt #(rect round-rect oval line)
(random 4))
:x (random (- w 20.0d0))
:y (random (- h 20.0d0))
:width (+ 20 (random 100.0d0))
:height (+ 20 (random 100.0d0))
:color (elt *colors* (random (length *colors*)))
:fill-color (elt *colors* (random (length *colors*)))
:line-width (random 10.0d0)
:filled (zerop (random 2)))))))
'(
(ccl:setenv "JBETRACE" "true" t)
(ccl:setenv "JBETRACE" "false" t)
(close-backend)
(open-backend :program-name "Test Program")
(defparameter *w* (make-instance 'window :title "Test Window"
:width 512.0d0
:height 342.0d0
:x 50.0d0
:y 50.0d0))
(progn
(compound-add *w* (make-instance 'label :text "Text:"
:x 10 :y 40 :width 100 :height 20))
(let ((tf (make-instance 'text-field :nchars 20 :action-command "TEXT"
:x 60 :y 60 :width 100 :height 20)))
(compound-add *w* tf)
(set-text tf "Doctor Who")
(defparameter *t* tf))
(compound-add *w* (make-instance 'button :label "OK" :action-command "OK"
:x 10 :y 60 :width 60 :height 20))
(defparameter *c* (make-instance 'chooser :items '("Red" "Green" "Blue")
:x 20 :y 80))
(compound-add *c*))
(compound-remove *w* (aref (components *w*) 2))
(defparameter *l1* (aref (components *w*) 0))
(defparameter *t1* (aref (components *w*) 1))
(defparameter *l2* (aref (components *w*) 2))
(defparameter *t2* (aref (components *w*) 3))
(progn
(set-window-resizable *w*)
(progn (set-object-size *w* 512 342)
(repaint-windows)
(set-object-location *w* 30 30))
(progn (set-object-location *l1* 10 40) (set-object-location *t1* 50 20))
(set-object-location *l2* 10 70) (set-object-location *t2* 50 50)
(set-object-location (aref (components *w*) 2) 60 60)
(components *w*)
(text *t1*)"Doctor Who and the Daleks")
(object.contains *w* 11.0d0 61.0d0)
)
;;;; THE END ;;;;
This source diff could not be displayed because it is too large. You can view the blob instead.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment