1 | ; -*- Mode: Lisp; Package: GUI; -*- |
---|
2 | |
---|
3 | (in-package "GUI") |
---|
4 | |
---|
5 | (defclass sequence-window-controller (ns:ns-window-controller) |
---|
6 | ((table-view :foreign-type :id :reader sequence-window-controller-table-view) |
---|
7 | (sequence :initform nil :initarg :sequence :type sequence :reader sequence-window-controller-sequence) |
---|
8 | (result-callback :initarg :result-callback) |
---|
9 | (display :initform #'(lambda (item stream) (prin1 item stream)) :initarg :display) |
---|
10 | (title :initform "Sequence dialog" :initarg :title)) |
---|
11 | (:metaclass ns:+ns-object)) |
---|
12 | |
---|
13 | |
---|
14 | (objc:defmethod #/init ((self sequence-window-controller)) |
---|
15 | (call-next-method) |
---|
16 | (let* ((w (new-cocoa-window :activate nil)) |
---|
17 | (contentview (#/contentView w)) |
---|
18 | (contentframe (#/frame contentview)) |
---|
19 | (scrollview (make-instance 'ns:ns-scroll-view :with-frame contentframe))) |
---|
20 | (#/setWindow: self w) |
---|
21 | (#/setDelegate: w self) |
---|
22 | (#/setWindowController: w self) |
---|
23 | (#/setHasVerticalScroller: scrollview t) |
---|
24 | (#/setHasHorizontalScroller: scrollview t) |
---|
25 | (#/setAutohidesScrollers: scrollview t) |
---|
26 | (#/setRulersVisible: scrollview nil) |
---|
27 | (#/setAutoresizingMask: scrollview (logior |
---|
28 | #$NSViewWidthSizable |
---|
29 | #$NSViewHeightSizable)) |
---|
30 | (#/setAutoresizesSubviews: (#/contentView scrollview) t) |
---|
31 | (let* ((table-view (make-instance 'ns:ns-table-view))) |
---|
32 | (#/setDocumentView: scrollview table-view) |
---|
33 | (#/release table-view) |
---|
34 | (#/setColumnAutoresizingStyle: table-view #$NSTableViewUniformColumnAutoresizingStyle) |
---|
35 | (setf (slot-value self 'table-view) table-view) |
---|
36 | (let* ((column (make-instance 'ns:ns-table-column :with-identifier #@""))) |
---|
37 | (#/setEditable: column nil) |
---|
38 | (#/setResizingMask: column #$NSTableColumnAutoresizingMask) |
---|
39 | (#/addTableColumn: table-view column) |
---|
40 | (#/release column)) |
---|
41 | (#/setAutoresizingMask: table-view (logior |
---|
42 | #$NSViewWidthSizable |
---|
43 | #$NSViewHeightSizable)) |
---|
44 | (#/sizeToFit table-view) |
---|
45 | (#/setDataSource: table-view self) |
---|
46 | (#/setTarget: table-view self) |
---|
47 | (#/setHeaderView: table-view +null-ptr+) |
---|
48 | (#/setUsesAlternatingRowBackgroundColors: table-view t) |
---|
49 | (#/setDoubleAction: table-view (@selector #/sequenceDoubleClick:)) |
---|
50 | (#/addSubview: contentview scrollview) |
---|
51 | (#/release scrollview) |
---|
52 | self))) |
---|
53 | |
---|
54 | (objc:defmethod (#/dealloc :void) ((self sequence-window-controller)) |
---|
55 | (call-next-method)) |
---|
56 | |
---|
57 | (objc:defmethod (#/windowWillClose: :void) ((self sequence-window-controller) |
---|
58 | notification) |
---|
59 | (declare (ignore notification)) |
---|
60 | (#/autorelease self)) |
---|
61 | |
---|
62 | (objc:defmethod (#/sequenceDoubleClick: :void) |
---|
63 | ((self sequence-window-controller) sender) |
---|
64 | (let* ((n (#/clickedRow sender))) |
---|
65 | (when (>= n 0) |
---|
66 | (with-slots (sequence result-callback) self |
---|
67 | (funcall result-callback (elt sequence n)))))) |
---|
68 | |
---|
69 | (objc:defmethod (#/numberOfRowsInTableView: :<NSI>nteger) |
---|
70 | ((self sequence-window-controller) view) |
---|
71 | (declare (ignore view)) |
---|
72 | (length (slot-value self 'sequence))) |
---|
73 | |
---|
74 | |
---|
75 | (objc:defmethod #/tableView:objectValueForTableColumn:row: |
---|
76 | ((self sequence-window-controller) view column (row :<NSI>nteger)) |
---|
77 | (declare (ignore column view)) |
---|
78 | (with-slots (display sequence) self |
---|
79 | (#/autorelease |
---|
80 | (%make-nsstring (with-output-to-string (s) |
---|
81 | (funcall display (elt sequence row) s)))))) |
---|
82 | |
---|
83 | (defmethod initialize-instance :after ((self sequence-window-controller) &key &allow-other-keys) |
---|
84 | (let* ((window (#/window self))) |
---|
85 | (with-slots (title) self |
---|
86 | (when title (#/setTitle: window (%make-nsstring title)))) |
---|
87 | (#/reloadData (sequence-window-controller-table-view self)) |
---|
88 | (#/performSelectorOnMainThread:withObject:waitUntilDone: |
---|
89 | self |
---|
90 | (@selector #/showWindow:) |
---|
91 | +null-ptr+ |
---|
92 | nil))) |
---|
93 | |
---|
94 | ;;; Looks like a "util" to me ... |
---|
95 | (defun pathname-to-url (pathname) |
---|
96 | (make-instance 'ns:ns-url |
---|
97 | :file-url-with-path |
---|
98 | (%make-nsstring (native-translated-namestring pathname)))) |
---|
99 | |
---|
100 | (defun cgfloat (number) |
---|
101 | (float number ccl::+cgfloat-zero+)) |
---|
102 | |
---|
103 | (defun color-values-to-nscolor (red green blue alpha) |
---|
104 | (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color |
---|
105 | (cgfloat red) |
---|
106 | (cgfloat green) |
---|
107 | (cgfloat blue) |
---|
108 | (cgfloat alpha))) |
---|
109 | |
---|
110 | (defun windows () |
---|
111 | (let* ((win-arr (#/orderedWindows *NSApp*)) |
---|
112 | (ret nil)) |
---|
113 | (dotimes (i (#/count win-arr)) |
---|
114 | (push (#/objectAtIndex: win-arr i) ret)) |
---|
115 | (nreverse ret))) |
---|
116 | |
---|
117 | (defun log-debug (format-string &rest args) |
---|
118 | (#_NSLog (ccl::%make-nsstring (apply #'format nil format-string args)))) |
---|
119 | |
---|
120 | (defun assume-cocoa-thread () |
---|
121 | #+debug (assert (eq *current-process* *initial-process*))) |
---|
122 | |
---|
123 | (defmethod assume-not-editing ((whatever t))) |
---|
124 | |
---|