Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
467 lines (428 sloc) 17.2 KB
;;; windows.lisp --- an interactive block buffer editor
;; Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012 David O'Toole
;; Author: David O'Toole <>
;; Keywords:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU 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
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <>.
;;; Code:
(in-package :blocky)
(define-block window
(buffer :initform nil :documentation "The buffer of objects to be displayed.")
(rows :initform 10)
(columns :initform 10)
(point-row :initform 0)
(point-column :initform 0)
(mark-row :initform nil)
(mark-column :initform nil)
(cursor-blink-color :initform "magenta")
(cursor-blink-clock :initform 0)
(origin-row :initform 0 :documentation "Row number of top-left displayed cell.")
(origin-column :initform 0 :documentation "Column number of top-left displayed cell.")
(origin-height :initform nil)
(origin-width :initform nil)
(column-widths :documentation "A vector of integers where v(x) is the pixel width of window column x.")
(row-heights :documentation "A vector of integers where v(x) is the pixel height of window row x.")
(column-styles :documentation "A vector of property lists used to customize the appearance of columns.")
(row-spacing :initform 1 :documentation "Number of pixels to add between rows.")
(zebra-stripes :documentation "When non-nil, zebra stripes are drawn.")
(row-styles :documentation "A vector of property lists used to customize the appearance of rows.")
(border-style :initform t :documentation "When non-nil, draw cell borders.")
(draw-blanks :initform t :documentation "When non-nil, draw blank cells.")
(header-style :initform t :documentation "When non-nil, draw row and column headers.")
(header-line :initform nil :documentation "Formatted line to be displayed at top of window above spreadsheet.")
(status-line :initform nil :documentation "Formatted line to be displayed at bottom of window below spreadsheet.")
(scroll-margin :initform 0)
(display-style :initform :label)
(cursor-color :initform "yellow")
(focused :initform nil)
(tool :initform :clone :documentation "Keyword symbol identifying the method to be applied.")
(tool-methods :initform '(:clone :erase :inspect)))
(defparameter *default-buffer-name* "*scratch*")
(define-method initialize window (&optional (buffer *default-buffer-name*))
(with-fields (entry) self
(let ((buffer (find-buffer buffer)))
(initialize%super self)
(visit self buffer))))
(define-method set-tool window (tool)
"Set the current sheet's selected tool to TOOL."
(assert (member tool %tool-methods))
(setf %tool tool))
(define-method next-tool window ()
"Switch to the next available tool."
(with-fields (tool tool-methods) self
(let ((pos (position tool tool-methods)))
(assert pos)
(setf tool (nth (mod (1+ pos) (length tool-methods))
(say self (format nil "Changing tool operation to ~S" tool)))))
(define-method set-modified window (&optional (value t))
(with-fields (buffer) self
(with-fields (name) buffer
(set-resource-modified-p name value))))
(define-method apply-tool window (data)
"Apply the current window's tool to the DATA."
(set-modified self)
(with-fields (tool tool-methods) self
(send nil tool self data)))
(define-method set-mark window ()
(setf %mark-row %point-row>
<mark-column %point-column)
(say self (format nil "Mark set at (~S, ~S)." %mark-row %mark-column)))
(define-method clear-mark window ()
(setf %mark-row nil %mark-column nil)
(say self "Mark cleared."))
(define-method mark-region window ()
(with-fields (mark-row mark-column point-row point-column) self
(if (and (integerp mark-row) (integerp mark-column))
(values (min mark-row point-row)
(min mark-column point-column)
(max mark-row point-row)
(max mark-column point-column))
(values nil nil nil nil))))
(define-method visit window (&optional (buffer *default-buffer-name*))
"Visit the buffer BUFFER with the current window. If BUFFER is a =buffer=
object, visit it and add the buffer to the buffer collection. If BUFFER is a
string, visit the named buffer. If the named buffer does not exist, a
default buffer is created. If BUFFER is a list, it is interpreted as a
buffer address, and a new buffer is generated according to that address.
(let ((buffer (find-buffer buffer)))
(assert (object-p buffer))
(setf %buffer-name (field-value :name buffer))
(say self (format nil "Visiting buffer ~S" %buffer-name))
(set-resource-modified-p %buffer-name t)
(setf %buffer buffer)
(install-keybindings self)
(setf %rows (field-value :height buffer))
(setf %columns (field-value :width buffer))
(assert (integerp %rows))
(assert (integerp %columns))
(setf %point-row 0)
(setf %point-column 0)
(clear-mark self)
(setf %point-column (min %columns %point-column))
(setf %point-row (min %rows %point-row))
(setf %point-column (min %columns %point-column))
(setf %column-widths (make-array (+ 1 %columns) :initial-element 0)
%row-heights (make-array (+ 1 %rows) :initial-element 0)
%column-styles (make-array (+ 1 %columns))
%row-styles (make-array (+ 1 %rows)))
(layout self)))
(defparameter *blank-cell-string* '(" ........ "))
(define-method layout window ()
(with-field-values (rows columns display-style buffer
column-widths row-heights) self
(when buffer
(with-field-values (grid) buffer
(let ((height 0)
(width 0)
cell location)
(labels ((update-height (row pixels)
(setf (aref row-heights row)
(max (aref row-heights row) pixels)))
(update-width (column pixels)
(setf (aref column-widths column)
(max (aref column-widths column) pixels))))
;; reset geometry
(dotimes (row rows)
(update-height row 0))
(dotimes (column columns)
(update-width column 0))
;; now measure
(dotimes (row rows)
(dotimes (column columns)
(setf location (aref grid row column))
(when (and location (not (zerop (fill-pointer location))))
(setf cell (aref location (- (fill-pointer location) 1)))
(update-height row (height cell))
(update-width column (width cell)))))))))))
(defparameter *even-columns-format* '(:background "gray50" :foreground "gray10"))
(defparameter *odd-columns-format* '(:background "gray45" :foreground "gray10"))
(define-method handle-event window (event)
;; possibly forward event to current cell. used for the event cell, see below.
(if (or (and (equal "RETURN" (first event))
(equal :control (second event)))
(equal "ESCAPE" (first event)))
(send-parent self :initialize self)
(let* ((cell (selected-cell self))
(widget (when cell (field-value :widget cell))))
(cond ((and cell (has-method :handle-key cell))
(or (handle-key cell event)
(send-parent self :handle-key self event)))
((and widget %entered)
(prog1 nil (handle-key widget event)))
(t (send-parent self :handle-key self event)))))
(layout self)))
(define-method hit window (x0 y0)
(with-field-values (row-heights column-widths origin-row origin-column rows columns x y width height)
(when (within-extents x0 y0 x y (+ x width) (+ y height))
(let* ((x %x)
(y %y)
(loop for column from origin-column to columns
do (incf x (aref column-widths column))
when (> x x0) return column))
(loop for row from origin-row to rows
do (incf y (aref row-heights row))
when (> y y0) return row)))
(when (and (integerp selected-column) (integerp selected-row))
(when (array-in-bounds-p (field-value :grid %buffer)
selected-row selected-column)
(prog1 t
(setf %point-row selected-row
%point-column selected-column))))))))
(define-method draw window ()
(when %buffer
(with-field-values (point-row point-column row-heights buffer buffer-name
origin-row origin-column header-line status-line
mark-row mark-column width height
display-style header-style tool tool-methods entered focused
row-spacing rows columns draw-blanks column-widths) self
(when %computing (compute self))
;; (layout self)
(let* ((image %image)
(widget-width %width)
(widget-height %height)
(block searching
(let ((width 0))
(loop for column from origin-column to columns
do (incf width (aref column-widths column))
(when (> width widget-width)
(return-from searching (- column 1))))
(return-from searching (- columns 1)))))
(block searching
(let ((height (if (and header-line header-style)
(formatted-line-height header-line)
(loop for row from origin-row to rows
do (incf height (aref row-heights row))
(when (> height widget-height)
(return-from searching (- row 1))))
(return-from searching (- rows 1)))))
(x 0)
(y 0)
(cursor-dimensions nil)
(mark-dimensions nil))
;; store some geometry
(setf %origin-width (- rightmost-visible-column origin-column))
(setf %origin-height (- bottom-visible-row origin-row))
;; see if current cell has a tooltip
;; (let ((selected-cell (cell-at self point-row point-column)))
;; (when (object-p selected-cell)
;; (setf header-line (field-value :tooltip selected-cell))))
;; draw header line with tooltip, if any
(multiple-value-bind (top left bottom right) (mark-region self)
(let ((x0 0)
(y0 0)
(x1 width)
(y1 height))
(when (and header-line header-style)
(render-formatted-line header-line 0 y :destination image)
(incf y (formatted-line-height header-line)))
;; TODO column header, if any
;; (message "GEOMETRY: ~S" (list :origin-row origin-row
;; :origin-column origin-column
;; :right rightmost-visible-column
;; :bottom bottom-visible-row))
(loop for row from origin-row to bottom-visible-row do
(setf x 0)
(loop for column from origin-column to rightmost-visible-column do
(let ((column-width (aref column-widths column))
(row-height (aref row-heights row))
(cell (cell-at self row column)))
;; possibly set up region drawing info
(when (equal row top)
(setf y0 y))
(when (equal row bottom)
(setf y1 (+ y row-height)))
(when (equal column left)
(setf x0 x))
(when (equal column right)
(setf x1 (+ x column-width)))
;; render the cell
(if (null cell)
(when draw-blanks
(draw-box x y
:stroke-color "gray30"
:color (if (evenp column) "gray50" "gray45")
:destination image))
;; see also cells.lisp
(ecase display-style
(:label (render cell image x y column-width))
(:image (if (in-category cell :drawn)
(push (list cell x y) pending-draws)
(when (field-value :image cell)
(draw-image (find-resource-object
(field-value :image cell)) x y :destination image)))))
(when entered
(draw-rectangle x y
:color "red"
:destination image))))
;; visually indicate edges of map with a yellow line
(let ((iwid 2))
(when (= rightmost-visible-column (- columns 1) column)
(draw-box (+ x column-width) y iwid row-height :stroke-color "yellow" :color "yellow"
:destination image))
(when (= 0 column)
(draw-box 0 y iwid row-height :stroke-color "yellow" :color "yellow"
:destination image))
(when (= bottom-visible-row row (- rows 1))
(draw-box x (+ y row-height) column-width iwid :stroke-color "yellow" :color "yellow"
:destination image))
(when (= 0 row)
(draw-box x 0 column-width iwid :stroke-color "yellow" :color "yellow"
:destination image)))
;; possibly save cursor and mark drawing info for this cell
(when (and (= row point-row) (= column point-column))
(setf cursor-dimensions (list x y column-width row-height)))
(when (and (integerp mark-row) (integerp mark-column) (= row mark-row) (= column mark-column))
(setf mark-dimensions (list x y column-width row-height)))
;; move to next column right
(incf x (aref column-widths column))))
;; move to next row down ;; TODO fix row-spacing
(incf y (+ (if (eq :image display-style)
0 0) (aref row-heights row))))
;; draw any pending drawn cells
(dolist (args pending-draws)
(destructuring-bind (cell x y) args
(draw cell x y image)))
;; create status line
;; TODO break this formatting out into variables
(setf status-line
(list (format nil " ( ~A ) " buffer-name) :foreground (if focused "yellow" "white")
:background (if focused "red" "blue"))
(list (format nil " ~A (~S, ~S) ~Sx~S "
tool point-row point-column rows columns)
:foreground "white"
:background "gray20")))
;; draw status line
(when status-line
(let* ((ht (formatted-line-height status-line))
(sy (- %height 1 ht)))
(draw-box 0 sy %width ht :color "gray20"
:stroke-color "gray20" :destination image)
(render-formatted-line status-line
0 sy
:destination image)))
;; render cursor and mark, if any
(when cursor-dimensions
(destructuring-bind (x y w h) cursor-dimensions
(draw-cursor self x y w h)))
(when mark-dimensions
(destructuring-bind (x y w h) mark-dimensions
(draw-mark self x y w h)))
(when (and (integerp mark-row) (integerp mark-column)
(notany #'null (list x0 y0 x1 y1)))
(draw-region self x0 y0 (- x1 x0) (- y1 y0)))))))))
(define-method scroll window ()
(with-fields (point-row point-column origin-row origin-column scroll-margin
origin-height origin-width buffer rows columns) self
(when (or
;; too far left
(> (+ origin-column scroll-margin)
;; too far right
(> point-column
(- (+ origin-column origin-width)
;; too far up
(> (+ origin-row scroll-margin)
;; too far down
(> point-row
(- (+ origin-row origin-height)
;; yes. recenter.
(setf origin-column
(max 0
(min (- columns origin-width)
(- point-column
(truncate (/ origin-width 2))))))
(setf origin-row
(max 0
(min (- rows origin-height)
(- point-row
(truncate (/ origin-height 2)))))))))
(define-method draw-cursor window (x y width height)
(with-fields (cursor-color cursor-blink-color cursor-blink-clock focused) self
(decf cursor-blink-clock)
(when (minusp cursor-blink-clock)
(setf cursor-blink-clock *form-cursor-blink-time*))
(let ((color (if (or (null focused)
(< (truncate (/ *form-cursor-blink-time* 2))
(draw-rectangle x y width height :color color :destination %image))))
(define-method draw-mark window (x y width height)
(draw-rectangle x y width height :color "white" :destination %image))
(define-method draw-region window (x y width height)
(draw-rectangle x y width height :color "cyan" :destination %image))
(define-method move-cursor window (direction)
"Move the cursor one step in DIRECTION.
DIRECTION is one of :up :down :right :left."
(unless %entered
(with-field-values (point-row point-column rows columns) self
(let ((cursor (list point-row point-column)))
(setf cursor (ecase direction
(:up (if (= 0 point-row)
(list (- point-row 1) point-column)
(:left (if (= 0 point-column)
(list point-row (- point-column 1))
(:down (if (< point-row (- rows 1))
(list (+ point-row 1) point-column)
(:right (if (< point-column (- columns 1))
(list point-row (+ point-column 1))
(destructuring-bind (r c) cursor
(setf %point-row r %point-column c))
;; possibly scroll
(scroll self)))))
(define-method move-cursor-up window ()
(move-cursor self :up))
(define-method move-cursor-down window ()
(move-cursor self :down))
(define-method move-cursor-left window ()
(move-cursor self :left))
(define-method move-cursor-right window ()
(move-cursor self :right))
(define-method move-end-of-line window ()
(unless %entered
(setf %point-column (1- %columns))
(scroll self)))
(define-method move-beginning-of-line window ()
(unless %entered
(setf %point-column 0)
(scroll self)))
(define-method move-end-of-column window ()
(unless %entered
(setf %point-row (1- %rows))
(scroll self)))
(define-method move-beginning-of-column window ()
(unless %entered
(setf %point-row 0)
(scroll self)))
;;; windows.lisp ends here
Something went wrong with that request. Please try again.