5.1 KiB
5.1 KiB
Strata
Package
(in-package :cl)
(defpackage :strata
(:use :clim :clim-lisp)
(:import-from :bordeaux-threads
:make-thread :destroy-thread)
(:import-from :strata-format
:text :section
:make-document :make-section :make-text :make-layout
:add-node :add-layout
:document-nodes
:node-text)
(:export :run-strata))
(in-package :strata)Test document
(defvar *doc* (make-document))
;; the first argument to each make-* function is the version
(add-node (make-section 1 "Title") *doc*)
(add-node (make-text 1 "Some text") *doc*)
(add-layout (make-layout 1 (document-nodes *doc*)) *doc*)
;; *doc* =>
;; #<DOCUMENT NIL
;; (#<TEXT 1 NIL NIL "Some text"> #<SECTION 1 NIL NIL "Title">)
;; NIL
;; (#<LAYOUT 1 NIL NIL NIL (#<SECTION 1 NIL NIL "Title">
;; #<TEXT 1 NIL NIL "Some text">)>)>Application frame
(define-application-frame strata ()
((%document :initform *doc*
:initarg :document
:accessor document)
(%cursor :initform 0
:initarg :cursor
:accessor cursor))
(:pointer-documentation t)
(:panes (app :application
:height (graft-height (find-graft))
:width (graft-width (find-graft))
:display-function 'display-document)
(int :interactor))
(:layouts (default (vertically () app int))))Display
current-document
(defun current-document ()
(document *application-frame*))cursor
(defclass cursor ()
((blink-interval :initarg :blink-interval
:initform 0.5
:accessor blink-interval
:documentation "Frequency of cursor blink, in seconds. If nil, disable cursor blinking.")
(color :initarg :color
:accessor color
:documentation "Color of cursor.")
(filled-p :initarg :filled-p
:initform t
:accessor filled-p
:documentation "Whether cursor rectangle should be filled.")
(width :initarg :width
:accessor width
:documentation "Width of cursor.")))display methods
(defmethod display ((section section) pane)
(with-output-as-presentation (pane section 'section)
(format pane "~a~%" (node-text section))))
(defmethod display ((text text) pane)
(with-output-as-presentation (pane text 'text)
(format pane "~a~%" (node-text text))))display-document-1
(defun display-document-1 (tree pane)
(let ((elt (first tree)))
(cond ((consp elt)
(display-document-1 elt pane))
((not (null elt))
(display elt pane)
(display-document-1 (rest tree) pane)))))display-document
(defparameter *cursor-thread* nil)
(defun draw-or-blink-cursor ()
(unless *cursor-thread*
(let ((application-frame *application-frame*)
(debug-io *debug-io*))
(setf *cursor-thread*
(make-thread
(lambda ()
(with-slots (%cursor) application-frame
(loop
with pane = (frame-standard-output application-frame)
with cursor-height = (cursor-height pane)
with cursor-width = (text-style-width *default-text-style* pane)
do
(let ((x1 (1+ (* %cursor cursor-width)))
(y1 (+ %cursor 0.5))
(x2 (1- (* %cursor cursor-width))))
(format debug-io
"blink: cursor ~a~%cursor position: ~a ~a ~a ~a~%"
%cursor x1 y1 x2 cursor-height)
(sleep 0.5)
(draw-rectangle* pane x1 y1 x2 cursor-height)
(sleep 0.5)
(medium-clear-area pane x1 y1 x2 cursor-height)))))
:name "cursor")))))
(defun display-document (frame pane)
;; (format *debug-io* "*application-frame*: ~a~%" *application-frame*)
(draw-or-blink-cursor)
(display-document-1 (document-nodes (current-document)) pane))
(define-strata-command (com-forward-character :name t :menu t :keystroke :rightarrow) ()
(with-slots (%cursor) *application-frame*
(incf %cursor)
(format *debug-io* "~%forward-character: cursor ~a~%" %cursor)))
(defmethod frame-exit :before (frame)
(ignore-errors (destroy-thread *cursor-thread*))
(setf *cursor-thread* nil))
(defun cursor-height (pane)
(text-style-height *default-text-style* pane))refresh
(define-strata-command (com-refresh :name t) ())run-strata
(defun run-strata (&optional dir)
(run-frame-top-level (make-application-frame 'strata)))