mirror of
https://gitlab.com/eql/EQL5.git
synced 2025-12-13 13:50:29 -08:00
390 lines
15 KiB
Common Lisp
390 lines
15 KiB
Common Lisp
;;; Palindrome "PATERNOSTER"
|
|
;;;
|
|
;;; N.B: If you load this file in Slime, you need to use QLOAD instead of LOAD!
|
|
|
|
(in-package :eql-user)
|
|
|
|
(require :definitions "definitions")
|
|
|
|
(defvar *generate-html/js-version* nil) ; command line option :html
|
|
|
|
(dolist (arg (mapcar 'read-from-string (rest (|arguments.QCoreApplication|))))
|
|
(if (numberp arg)
|
|
(if (integerp arg)
|
|
(setf *window-width* arg)
|
|
(setf *window-opacity* arg))
|
|
(when (eql :html arg)
|
|
(setf *generate-html/js-version* t)))
|
|
(when (and *generate-html/js-version*
|
|
(not *window-width*))
|
|
(setf *window-width* 450)))
|
|
|
|
(defconstant +state-switch-event+ (+ |QEvent.User| 256))
|
|
(defconstant +size+ 20)
|
|
|
|
(defparameter *item-size* (list +size+ +size+))
|
|
(defparameter *view-size* (list (* +size+ (length (caar *states*)))
|
|
(* +size+ (length (car *states*)))))
|
|
(defparameter *color-m* nil)
|
|
|
|
(defvar *main* (qnew "QWidget"
|
|
"mouseTracking" t
|
|
"windowOpacity" *window-opacity*))
|
|
(defvar *view* (qnew "QGraphicsView"
|
|
"mouseTracking" t
|
|
"frameShape" |QFrame.NoFrame|))
|
|
(defvar *timer* (qnew "QTimer"
|
|
"singleShot" t))
|
|
|
|
(defmacro push* (item list)
|
|
`(setf ,list (nconc ,list (list ,item))))
|
|
|
|
;;; custom easing curve (see both "../cpp/lib.h" and "exe/main.h")
|
|
;;; see CUSTOM-EASING-FUNCTION in "definitions.lisp"
|
|
|
|
(let (curve)
|
|
(defun custom-easing-curve ()
|
|
(or curve
|
|
(setf curve (cond ((directory "*easing_curve.*")
|
|
(! "easingCurve" (:qt (qload-c++ "easing_curve"))))
|
|
((string= "Qt_EQL_Application"
|
|
(|className| (|metaObject| (qapp))))
|
|
(! "easingCurve" (:qt (qapp))))
|
|
(t
|
|
(qnew "QEasingCurve(QEasingCurve::Type)" |QEasingCurve.Linear|))))))) ; fallback
|
|
|
|
;;; state-switch-event
|
|
|
|
(let (event-n)
|
|
(defun new-state-switch-event (n)
|
|
(setf event-n n)
|
|
(qnew "QEvent(QEvent::Type)" +state-switch-event+))
|
|
(defun event-number ()
|
|
event-n))
|
|
|
|
;;; state-switch-transition
|
|
|
|
(defstruct (state-switch-transition (:conc-name transition-))
|
|
(q (qnew "QAbstractTransition"))
|
|
(number nil))
|
|
|
|
(defmethod the-qt-object ((object state-switch-transition))
|
|
(transition-q object))
|
|
|
|
(defun new-state-switch-transition (n)
|
|
(let ((trans (make-state-switch-transition :number n)))
|
|
(qoverride trans "eventTest(QEvent*)"
|
|
(lambda (event)
|
|
(and (= +state-switch-event+
|
|
(|type| event))
|
|
(= (transition-number trans)
|
|
(event-number)))))
|
|
trans))
|
|
|
|
;;; state-switcher
|
|
|
|
(defstruct (state-switcher (:conc-name :switcher-))
|
|
(q nil)
|
|
(state-count 0)
|
|
(last-index 0))
|
|
|
|
(defmethod the-qt-object ((object state-switcher))
|
|
(switcher-q object))
|
|
|
|
(let ((ini t))
|
|
(defun new-state-switcher (machine name)
|
|
(let ((switch (make-state-switcher :q (qnew "QState(QState*)" machine
|
|
"objectName" name))))
|
|
(qoverride switch "onEntry(QEvent*)"
|
|
(lambda (event)
|
|
(let ((n (1+ (switcher-last-index switch))))
|
|
(when (> n (switcher-state-count switch))
|
|
(setf n 1))
|
|
(when ini
|
|
(setf ini nil)
|
|
(incf n)
|
|
(|setInterval| *timer* (* 2 *duration*)))
|
|
(setf (switcher-last-index switch) n)
|
|
(|postEvent| (|machine| switch)
|
|
(new-state-switch-event n)))))
|
|
switch)))
|
|
|
|
;;;
|
|
;;; main
|
|
;;;
|
|
|
|
(defvar *font* (x:let-it (|font.QApplication|) (|setBold| x:it t)))
|
|
(defvar *graphics-items* nil)
|
|
|
|
(let (items)
|
|
(defun new-graphics-item (text color id)
|
|
(when *generate-html/js-version*
|
|
(save-item-pixmap text color id))
|
|
(let ((item (qnew "QGraphicsWidget")))
|
|
(qoverride item "paint(QPainter*,QStyleOptionGraphicsItem*,QWidget*)"
|
|
(lambda (painter s w)
|
|
(x:do-with painter
|
|
(|fillRect| (mapcar '+ (|rect| item) '(1 1 -2 -2)) color)
|
|
(|setFont| *font*)
|
|
(|setPen| "black")
|
|
(|drawText| (|rect| item) |Qt.AlignCenter| text))))
|
|
(push (cons id item) *graphics-items*)
|
|
item))
|
|
(defun id-item (id)
|
|
(cdr (assoc id *graphics-items*)))
|
|
(defun items ()
|
|
(or items (setf items
|
|
(loop :for i :to (1- (length *graphics-items*))
|
|
:collect (id-item (intern (string (code-char (+ i #.(char-code #\A)))))))))))
|
|
|
|
(defun create-geometry-state (parent objects positions)
|
|
(let ((result (qnew "QState(QState*)" parent)))
|
|
(mapc (lambda (object pos)
|
|
(|assignProperty| result object "geometry" (qnew "QVariant(QRect)"
|
|
(append (mapcar '* (mapcar '- pos '(1 1)) *item-size*)
|
|
*item-size*))))
|
|
objects positions)
|
|
result))
|
|
|
|
(defun add-state (state-switcher state animation)
|
|
(let ((trans (new-state-switch-transition (incf (switcher-state-count state-switcher)))))
|
|
(x:do-with trans
|
|
(|setTargetState| state)
|
|
(|addAnimation| animation))
|
|
(|addTransition| state-switcher trans)))
|
|
|
|
(let (animations groups)
|
|
(defun add-property-animation (anim-group button property curve-type duration &optional pause)
|
|
(let ((anim (qnew "QPropertyAnimation(QObject*,QByteArray)" button (x:string-to-bytes property)))
|
|
(group (if pause
|
|
(let ((group (qnew "QSequentialAnimationGroup(QObject*)" anim-group)))
|
|
(|addPause| group pause)
|
|
(push* group groups)
|
|
group)
|
|
anim-group)))
|
|
(x:do-with anim
|
|
(|setDuration| duration)
|
|
(|setEasingCurve| (if (= |QEasingCurve.Custom| curve-type)
|
|
(custom-easing-curve)
|
|
(qnew "QEasingCurve(QEasingCurve::Type)" curve-type))))
|
|
(push* anim animations)
|
|
(|addAnimation| group anim)
|
|
anim))
|
|
(defun change-easing-curve (curve)
|
|
(let* ((type (etypecase curve
|
|
(integer
|
|
curve)
|
|
(string
|
|
(symbol-value (intern (x:cc "QEasingCurve." curve))))))
|
|
(curve (if (= |QEasingCurve.Custom| type)
|
|
(custom-easing-curve)
|
|
(qnew "QEasingCurve(QEasingCurve::Type)" type))))
|
|
(setf *easing-curve* curve)
|
|
(dolist (anim animations)
|
|
(|setEasingCurve| anim curve))))
|
|
(defun change-duration (msec)
|
|
(setf *duration* msec)
|
|
(dolist (anim animations)
|
|
(|setDuration| anim msec))
|
|
(update-timer))
|
|
(defun change-pause (msec)
|
|
(setf *pause* msec)
|
|
(let ((n 0))
|
|
(dolist (group groups)
|
|
(let ((anim (|takeAnimation| group 1)))
|
|
(x:do-with group
|
|
(|clear|)
|
|
(|addPause| (* (incf n) msec))
|
|
(|addAnimation| anim)))))
|
|
(update-timer))
|
|
(defun update-timer ()
|
|
(|setInterval| *timer* (+ *duration* (* 4 *pause*) 1000))))
|
|
|
|
(defun item-count ()
|
|
(loop :for item :in *items*
|
|
:sum (length (third item))))
|
|
|
|
(defun create-geometry-states (group)
|
|
(flet ((item-pos (char list)
|
|
(let ((y 0))
|
|
(dolist (state list)
|
|
(incf y)
|
|
(x:when-it (position char state)
|
|
(return-from item-pos (list (1+ x:it) y)))))))
|
|
(let ((letters (loop :for i :to (item-count) :collect (code-char (+ i #.(char-code #\a)))))
|
|
states)
|
|
(dolist (state *states*)
|
|
(let (positions)
|
|
(dolist (char letters)
|
|
(push* (item-pos char state)
|
|
positions))
|
|
(push* (create-geometry-state group (items) positions)
|
|
states)))
|
|
states)))
|
|
|
|
(defun ini ()
|
|
(dolist (item *items*)
|
|
(let ((text (first item))
|
|
(color (second item)))
|
|
(dolist (id (third item))
|
|
(new-graphics-item text (if (eql 'm id) (setf *color-m* color) color) id))))
|
|
(let ((scene (qnew "QGraphicsScene"
|
|
"sceneRect" (append '(0 0) *view-size*)))
|
|
(machine (qnew "QStateMachine"))
|
|
(group (qnew "QState"
|
|
"objectName" "group"))
|
|
(anim-group (qnew "QParallelAnimationGroup"))
|
|
(layout (qnew "QHBoxLayout(QWidget*)" *main*)))
|
|
(qset-color *main* |QPalette.Window| *background*)
|
|
(|setBackgroundBrush| scene (qnew "QBrush(QColor)" *background*))
|
|
(x:do-with layout
|
|
(|addStretch|)
|
|
(|addWidget| *view*)
|
|
(|addStretch|))
|
|
(|setScene| *view* scene)
|
|
(dolist (item (items))
|
|
(|addItem| scene item))
|
|
(let ((pause 0))
|
|
(dolist (item (items))
|
|
(add-property-animation anim-group item "geometry" *easing-curve* *duration* (incf pause *pause*))))
|
|
(|setInterval| *timer* (/ *duration* 2))
|
|
(let ((states (create-geometry-states group))
|
|
(state-switcher (new-state-switcher machine "stateSwitcher")))
|
|
(dolist (state states)
|
|
(add-state state-switcher state anim-group))
|
|
(x:do-with group
|
|
(|setInitialState| (first states))
|
|
(|addTransition| *timer* (qsignal "timeout()") state-switcher)))
|
|
(x:do-with machine
|
|
(|addState| group)
|
|
(|setInitialState| group)
|
|
(|start|))
|
|
(qconnect group "entered()" *timer* "start()")
|
|
(qoverride *view* "resizeEvent(QResizeEvent*)"
|
|
(lambda (event)
|
|
(|fitInView| *view* (|sceneRect| scene))
|
|
(qcall-default)))
|
|
;; change background color on mouse move events outside of view
|
|
(qoverride *main* "mouseMoveEvent(QMouseEvent*)"
|
|
(lambda (event)
|
|
(qlet ((brush "QBrush(QColor)" (if (< (|x| event)
|
|
(/ (|width| *main*) 2))
|
|
*background*
|
|
*color-m*)))
|
|
(|setBackgroundBrush| scene brush))))
|
|
;; change background color on mouse move events inside of view
|
|
(qoverride *view* "mouseMoveEvent(QMouseEvent*)"
|
|
(lambda (event)
|
|
(qlet ((brush "QBrush(QColor)"
|
|
(|fromHsv.QColor|
|
|
(floor (* 359 (/ (|x| event) (|width| *view*))))
|
|
(floor (* 255 (/ (|y| event) (|height| *view*))))
|
|
255)))
|
|
(|setBackgroundBrush| scene brush))))
|
|
;; quit on mouse click
|
|
(dolist (w (list *main* *view*))
|
|
(qoverride w "mousePressEvent(QMouseEvent*)" (lambda (event) (qquit))))
|
|
;; pause on key Space
|
|
;; save screenshot on key S
|
|
;; quit on key Escape
|
|
(qadd-event-filter nil |QEvent.KeyPress|
|
|
(lambda (_ event)
|
|
(let ((key (|key| event)))
|
|
(case key
|
|
(#.|Qt.Key_Space|
|
|
(let ((active (|isActive| *timer*)))
|
|
(if active
|
|
(|stop| *timer*)
|
|
(x:do-with *timer*
|
|
(|timeout|)
|
|
(|start|)))
|
|
(qset-color *main* |QPalette.Window| (if active *color-pause* *background*))))
|
|
(#.|Qt.Key_S|
|
|
(let ((widget (|viewport| *view*)))
|
|
(|save| (|grab| widget (|rect| widget))
|
|
"screenshot.png")))
|
|
(#.|Qt.Key_Escape|
|
|
(qquit))))))
|
|
(if *window-width*
|
|
(|setFixedSize| *view* (list *window-width* *window-width*))
|
|
(|setFixedWidth| *view* (apply 'min (nthcdr 2 (|screenGeometry| (|desktop.QApplication|))))))
|
|
(qlater (lambda () (|setPos.QCursor| (|pos| *main*))))
|
|
(if *window-width*
|
|
(|show| *main*)
|
|
(|showFullScreen| *main*))
|
|
(|raise| *main*)))
|
|
|
|
;;;
|
|
;;; for *generate-html/js-version* (command line option :html)
|
|
;;;
|
|
|
|
(defvar *positions-timer* (qnew "QTimer"))
|
|
(defvar *item-positions* nil)
|
|
|
|
(defun normalize (x)
|
|
(truncate (+ 0.5 (/ (* x *window-width*) 300))))
|
|
|
|
(defun save-item-pixmap (text color id)
|
|
(qlet ((pixmap "QPixmap(QSize)" (mapcar 'normalize *item-size*)))
|
|
(|fill| pixmap "transparent")
|
|
(qlet ((painter "QPainter(QPixmap*)" pixmap)
|
|
(font* (qcopy *font*)))
|
|
(|setPointSize| font* (normalize (|pointSize| font*)))
|
|
(x:do-with painter
|
|
(|fillRect| (mapcar '+ (|rect| pixmap) '(1 1 -2 -2)) color)
|
|
(|setFont| font*)
|
|
(|setPen| "black")
|
|
(|drawText| (|rect| pixmap) |Qt.AlignCenter| text)))
|
|
(|save| pixmap (ensure-directories-exist (format nil "html/img/~D.png"
|
|
(1+ (- (char-code (char (symbol-name id) 0))
|
|
(char-code #\A))))))))
|
|
|
|
(let (ex-pos)
|
|
(defun collect-item-positions ()
|
|
(let ((pos (mapcar (lambda (it) (cons (car it) (mapcar 'normalize (|pos| (cdr it)))))
|
|
*graphics-items*)))
|
|
(unless (equal pos ex-pos)
|
|
(push pos *item-positions*)
|
|
(setf ex-pos pos)))))
|
|
|
|
(let (num)
|
|
(defun save-item-positions ()
|
|
(if num
|
|
(progn
|
|
(let (pos)
|
|
(dolist (p *item-positions*)
|
|
(push (sort p 'string< :key 'first) pos))
|
|
(with-open-file (s "meta/positions.js"
|
|
:direction :output :if-exists :append :if-does-not-exist :create)
|
|
(format s "~% var p~D = [" (incf num))
|
|
(dolist (p pos)
|
|
(dolist (xy p)
|
|
(format s "~D,~D," (second xy) (third xy))))
|
|
(format s "null];")))
|
|
(format t "~%[html] positions ~D/12" num)
|
|
(when (= 12 num)
|
|
(load "meta/generate.lisp")
|
|
(funcall (find-symbol "GENERATE-HTML") (item-count)
|
|
:width *window-width*
|
|
:pause 1500
|
|
:delay 50
|
|
:background "black")
|
|
(format t "~%[html] please see \"html/palindrome.htm\"~%~%")
|
|
(qq))
|
|
(setf *item-positions* nil))
|
|
(progn
|
|
(setf num 0)
|
|
(when (probe-file "meta/positions.js")
|
|
(delete-file "meta/positions.js"))))))
|
|
|
|
(defun ini-generate-html/js ()
|
|
(|setInterval| *positions-timer* 50)
|
|
(qconnect *positions-timer* "timeout()" 'collect-item-positions)
|
|
(qconnect *timer* "timeout()" 'save-item-positions)
|
|
(|start| *positions-timer*))
|
|
|
|
(progn
|
|
(ini)
|
|
(when *generate-html/js-version*
|
|
(ini-generate-html/js)))
|
|
|