diff --git a/README.md b/README.md index 40482de..81b0359 100644 --- a/README.md +++ b/README.md @@ -187,6 +187,7 @@ Demo Summary - 01-demo.lisp - Sparkey the Snake Game - 02-demo.lisp - Chat - Private instant messenger +- 03-demo.lisp - IDE - A very simple common lisp IDE Enhancements underway: diff --git a/demos/03-demo.lisp b/demos/03-demo.lisp new file mode 100644 index 0000000..e766f78 --- /dev/null +++ b/demos/03-demo.lisp @@ -0,0 +1,145 @@ +(defpackage #:clog-user + (:use #:cl #:clog) + (:export start-demo)) + +(in-package :clog-user) + +(defclass app-data () + ((body + :accessor body + :documentation "Store top level access on new window") + (drag-mutex + :reader drag-mutex + :initform (bordeaux-threads:make-lock) + :documentation "Serialize access to the on-mouse-down event.") + (in-drag + :accessor in-drag-p + :initform nil + :documentation "Ensure only one box is dragged at a time.") + (drag-x + :accessor drag-x + :documentation "The location of the left side of the box relative to mouse during drag.") + (drag-y + :accessor drag-y + :documentation "The location of the top of the box relative to mouse during drag."))) + +(defun on-mouse-down (obj data) + (let ((app (connection-data-item obj "app-data"))) + (bordeaux-threads:with-lock-held ((drag-mutex app)) + (setf (z-index obj) 1) + (unless (in-drag-p app) + (setf (in-drag-p app) t) + (let* ((mouse-x (getf data ':screen-x)) + (mouse-y (getf data ':screen-y)) + (obj-top (parse-integer (top obj) :junk-allowed t)) + (obj-left (parse-integer (left obj) :junk-allowed t))) + (setf (drag-x app) (- mouse-x obj-left)) + (setf (drag-y app) (- mouse-y obj-top)) + (if (eq (getf data ':event-type) :touch) + (progn + (set-on-touch-move obj 'on-mouse-move) + (set-on-touch-end obj 'stop-obj-grab) + (set-on-touch-cancel obj 'on-mouse-leave)) + (progn + (set-on-mouse-move obj 'on-mouse-move) + (set-on-mouse-up obj 'stop-obj-grab) + (set-on-mouse-leave obj 'on-mouse-leave)))))))) + +(defun on-mouse-move (obj data) + (let* ((app (connection-data-item obj "app-data")) + (x (getf data ':screen-x)) + (y (getf data ':screen-y))) + (setf (top obj) (format nil "~Apx" (- y (drag-y app)))) + (setf (left obj) (format nil "~Apx" (- x (drag-x app)))))) + +(defun on-mouse-leave (obj) + (let ((app (connection-data-item obj "app-data"))) + (setf (in-drag-p app) nil) + (set-on-touch-move obj nil) + (set-on-touch-end obj nil) + (set-on-touch-cancel obj nil) + (set-on-mouse-move obj nil) + (set-on-mouse-up obj nil) + (set-on-mouse-leave obj nil))) + +(defun stop-obj-grab (obj data) + (on-mouse-move obj data) + (on-mouse-leave obj)) + +(defgeneric create-window (clog-obj title + &key html-id content left top width height) + (:documentation "Create an html-window")) + +(defmethod create-window ((obj clog-obj) title &key + (html-id nil) + (top-bar "") + (content "") + (left 60) + (top 60) + (width 400) + (height 300)) + (unless html-id + (setf html-id (clog-connection:generate-id))) + + (let* ((app (connection-data-item obj "app-data")) + (win (create-child (body app) + (format nil + "
+
+ ~A + X + ~A +
+
~A
+
" + top left width height html-id title html-id top-bar html-id content) + :html-id html-id))) + (set-on-click (attach-as-child obj (format nil "~A-close" html-id)) + (lambda (obj) + (setf (hiddenp win) t))) + win)) + +(defun do-ide-file-new (obj) + (let* ((app (connection-data-item obj "app-data")) + (win (create-window obj "New window" + :left (random 600) + :top (+ 40 (random 400))))) + (create-child obj + (format nil + "" + (html-id win))) + (set-on-touch-start win 'on-mouse-down) + (set-on-mouse-down win 'on-mouse-down))) + +(defun do-ide-help-about (obj) + (let* ((app (connection-data-item obj "app-data")) + (about (create-window (body app) "About" + :top-bar "
+
CLOG
+
The Common Lisp Omnificent GUI
" + :content "

Demo 3
+
(c) 2021 - David Botton

" + :left (- (/ (width (body app)) 2) 100) + :width 200 + :height 200))) + (set-on-touch-start about 'on-mouse-down) + (set-on-mouse-down about 'on-mouse-down))) + +(defun on-new-window (body) + (let ((app (make-instance 'app-data))) + (setf (connection-data-item body "app-data") app) + (setf (body app) body) + (set-on-click (attach-as-child body "ide-file-new") #'do-ide-file-new) + (set-on-click (attach-as-child body "ide-help-about") #'do-ide-help-about) + (set-on-click (attach-as-child body "ide-logo") #'do-ide-help-about) + (run body))) + +(defun start-demo () + "Start demo." + (initialize #'on-new-window :boot-file "/demo/frame.html") + (open-browser)) diff --git a/demos/README.md b/demos/README.md index cd4381e..ae6e5d4 100644 --- a/demos/README.md +++ b/demos/README.md @@ -36,3 +36,4 @@ Demo Summary - 01-demo.lisp - Sparkey the Snake Game - 02-demo.lisp - Chat - Private instant messenger +- 03-demo.lisp - IDE - A very simple common lisp IDE diff --git a/static-files/demo/clogicon.png b/static-files/demo/clogicon.png new file mode 100644 index 0000000..070e074 Binary files /dev/null and b/static-files/demo/clogicon.png differ diff --git a/static-files/demo/clogwicon.png b/static-files/demo/clogwicon.png new file mode 100644 index 0000000..892822d Binary files /dev/null and b/static-files/demo/clogwicon.png differ diff --git a/static-files/demo/frame.html b/static-files/demo/frame.html new file mode 100644 index 0000000..4d4271f --- /dev/null +++ b/static-files/demo/frame.html @@ -0,0 +1,46 @@ + + + + + + + + + + + + + + + + +
+ +
+ +
+ New + Open... + Save + Save as... +
+
+
+ +
+ Copy + Paste +
+
+
+ +
+ About CLOG Demo 3 +
+
+ ⤢ +
+ + +