;;; Copyright (c) 1998-2018 ;;; John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen; ;;; see LICENSE for conditions ;;; Ann Copestake / John Carroll ;;; output active lists in a window - pass in an alist of string / ;;; data pairs, a window title, and an alist of menu command string / ;;; function pairs. Each function should take 1 argument: the data ;;; item associated with the string that is chosen (in-package :lkb) ;;; Appearance parameters (defun active-list-item-font () (clim:make-text-style :sans-serif :roman (or *parse-tree-font-size* 12))) (declaim (notinline active-list-item-font)) ;;; The active window (eval-when (:load-toplevel :compile-toplevel :execute) (defstruct thing object)) (eval-when (:load-toplevel :compile-toplevel :execute) (clim:define-presentation-type thing ())) (define-lkb-frame list-window ((pairs :initform nil :accessor list-window-pairs) (menu :initform nil :accessor list-window-menu)) :display-function 'draw-list-window :text-style (active-list-item-font) :width :compute :height *parse-window-height*) ; not :compute so window isn't excessively tall or short (defun draw-active-list (pairs title menu) (mp:run-function title #'draw-active-list-really pairs title menu)) (defun draw-active-list-really (pairs title menu) (let ((frame (clim:make-application-frame 'list-window :pretty-name title))) (setf (list-window-pairs frame) pairs) (setf (list-window-menu frame) menu) (clim:run-frame-top-level frame))) (defun draw-list-window (frame stream &key max-width max-height) (declare (ignore max-width max-height)) (clim:with-output-recording-options (stream :draw nil :record t) (dolist (pair (list-window-pairs frame)) (clim:with-output-as-presentation (stream (make-thing :object (cdr pair)) 'thing) (write-line (car pair) stream)))) (clim:replay (clim:stream-output-history stream) stream)) (define-list-window-command (com-list-window-menu) ((object 'thing :gesture (:select :menu nil))) (when (thing-p object) (clim:with-application-frame (frame) (pop-up-menu (loop for item in (list-window-menu frame) for command upfrom 0 collecting (list (car item) :value command)) #'(lambda (command) (funcall (cdr (nth command (list-window-menu frame))) (thing-object object)))))))