This repository has been archived by the owner on Apr 2, 2023. It is now read-only.
/
items.lisp
140 lines (107 loc) · 4.78 KB
/
items.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
#|
This file is a part of Qtools-UI
(c) 2015 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#
(in-package #:org.shirakumo.qtools.ui)
(in-readtable :qtools)
(defgeneric container (item-widget))
(defgeneric (setf container) (container item-widget))
(defgeneric widget-item (item-widget))
(defgeneric (setf widget-item) (item item-widget))
(defgeneric item-widget (item layout))
(defgeneric coerce-item (item layout))
(defgeneric item-at (place layout))
(defgeneric (setf item-at) (item place layout))
(defgeneric item-position (item layout &key key test test-not))
(defgeneric find-item (item layout &key key test test-not))
(defgeneric add-item (item layout))
(defgeneric insert-item (item place layout))
(defgeneric remove-item (item layout))
(defgeneric remove-item-at (place layout))
(defgeneric swap-items (a b layout))
(defgeneric swap-items-at (a b layout))
(defgeneric item-acceptable-p (item layout))
(defgeneric item< (a b))
(defgeneric item= (a b))
(defgeneric item> (a b))
(defgeneric item<= (a b))
(defgeneric item>= (a b))
(define-widget item-layout (QWidget layout)
())
(define-widget item-widget (QWidget)
((item :initarg :item :accessor widget-item)
(container :initarg :container :accessor container))
(:default-initargs :item NIL))
(define-print-method (instance item-widget stream)
(print-unreadable-object (instance stream :type T :identity T)
(format stream "~s ~a" :item (widget-item instance))))
(defun check-item-permitted (item layout)
(unless (item-acceptable-p item layout)
(cerror "Add the item anyway." "~a does not accept ~a." layout item)))
(defmethod (setf widget-item) ((widget qobject) (item-widget item-widget))
(setf (parent widget) item-widget)
(setf (slot-value item-widget 'item) widget))
(defmethod (setf widget-item) :around (item (item-widget item-widget))
(check-item-permitted item (container item-widget))
(call-next-method))
(defmethod item-widget (item (layout item-layout))
(find-widget item layout :key #'widget-item))
(defmethod coerce-item :around (item (item-layout item-layout))
(check-item-permitted item item-layout)
(call-next-method))
(defmethod coerce-item (item (layout item-layout))
(make-instance 'item-widget :item item :container layout))
(defmethod item-at (place (layout item-layout))
(let ((widget (widget place layout)))
(when widget (widget-item widget))))
(defmethod (setf item-at) (item place (layout item-layout))
(let ((widget (widget place layout)))
(if widget
(setf (widget-item widget) item)
(setf (widget place layout) (coerce-item item layout)))))
(defmethod item-position :around (item (layout item-layout) &key key test test-not)
(when (and test test-not)
(error "Cannot specify both TEST and TEST-NOT simultaneously."))
(call-next-method item layout :key (or key #'identity) :test (default-test test test-not) :test-not test-not))
(defmethod item-position (item (layout item-layout) &key key test test-not)
(widget-position item layout :key (lambda (widget) (funcall key (widget-item widget))) :test test :test-not test-not))
(defmethod find-item :around (item (layout item-layout) &key key test test-not)
(when (and test test-not)
(error "Cannot specify both TEST and TEST-NOT simultaneously."))
(call-next-method item layout :key (or key #'identity) :test (default-test test test-not) :test-not test-not))
(defmethod find-item (item (layout item-layout) &key key test test-not)
(widget-item (find-widget item layout :key (lambda (widget) (funcall key (widget-item widget))) :test test :test-not test-not)))
(defmethod add-item (item (layout item-layout))
(add-widget (coerce-item item layout) layout))
(defmethod insert-item (item place (layout item-layout))
(insert-widget (coerce-item item layout) place layout))
(defmethod remove-item (item (layout item-layout))
(remove-widget (item-widget item layout) layout))
(defmethod remove-item-at (place (layout item-layout))
(let ((widget (remove-widget place layout)))
(when widget (widget-item widget))))
(defmethod swap-items (a b (layout item-layout))
(swap-widgets (item-widget a layout) (item-widget b layout) layout))
(defmethod swap-items-at (a b (layout item-layout))
(swap-widgets a b layout))
(defmethod item-acceptable-p (item (layout item-layout))
T)
(defmethod item< ((a string) (b string))
(string< a b))
(defmethod item< ((a number) (b number))
(< a b))
(defmethod item< (a b)
(item< (princ-to-string a) (princ-to-string b)))
(defmethod item= ((a string) (b string))
(string= a b))
(defmethod item= ((a number) (b number))
(= a b))
(defmethod item= (a b)
(item= (princ-to-string a) (princ-to-string b)))
(defmethod item<= (a b)
(or (item= a b) (item< a b)))
(defmethod item>= (a b)
(not (item< a b)))
(defmethod item> (a b)
(not (item<= a b)))