This repository has been archived by the owner on Apr 2, 2023. It is now read-only.
-
-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathchannel-list.lisp
137 lines (112 loc) · 5.25 KB
/
channel-list.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
#|
This file is a part of lichat
(c) 2016 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#
(in-package #:org.shirakumo.lichat.lionchat)
(in-readtable :qtools)
(define-widget channel-list (QDockWidget)
((main :initarg :main :accessor main)
(channels :initform () :accessor channels)))
(defmethod (setf channels) :after (value (channel-list channel-list))
(update-listing channel-list))
(defmethod update ((channel-list channel-list) (update lichat-protocol:join))
(when (string= (lichat-protocol:from update)
(username (client update)))
(setf (channels channel-list)
(append (channels (client update))
(remove (client update) (channels channel-list) :key #'client)))))
(defmethod update ((channel-list channel-list) (update lichat-protocol:leave))
(when (string= (lichat-protocol:from update)
(username (client update)))
(setf (channels channel-list)
(append (channels (client update))
(remove (client update) (channels channel-list) :key #'client)))))
(define-initializer (channel-list setup)
(setf (q+:features channel-list) (q+:qdockwidget.dock-widget-movable))
(setf (q+:window-title channel-list) "Channels")
(setf (q+:object-name channel-list) "channel-list"))
(define-subwidget (channel-list list)
(make-instance 'qui:listing :draggable NIL
:sorting (lambda (a b)
(or (primary-p a)
(and (not (primary-p b))
(or (anonymous-p a)
(and (not (anonymous-p b))
(string< (name a) (name b)))))))))
(define-subwidget (channel-list scroller)
(q+:make-qscrollarea)
(setf (q+:widget-resizable scroller) T)
(setf (q+:widget scroller) list))
(define-subwidget (channel-list join)
(q+:make-qpushbutton "j")
(setf (q+:fixed-width join) 20))
(define-subwidget (channel-list create)
(q+:make-qpushbutton "c")
(setf (q+:fixed-width create) 20))
(define-subwidget (channel-list channelname)
(q+:make-qlineedit)
(setf (q+:placeholder-text channelname) "Channel name..."))
(define-subwidget (channel-list center)
(q+:make-qwidget)
(setf (q+:widget channel-list) center)
(setf (q+:size-policy center) (values (q+:qsizepolicy.preferred)
(q+:qsizepolicy.preferred))))
(define-subwidget (channel-list layout)
(q+:make-qgridlayout center)
(setf (q+:margin layout) 0)
(setf (q+:spacing layout) 5)
(q+:add-widget layout scroller 0 0 1 3)
(q+:add-widget layout channelname 1 0 1 1)
(q+:add-widget layout join 1 1 1 1)
(q+:add-widget layout create 1 2 1 1))
(define-slot (channel-list join) ()
(declare (connected join (clicked)))
(let ((name (q+:text channelname)))
(when (and (string/= "" name)
(channel channel-list))
(qsend (channel channel-list)
'lichat-protocol:join
:channel name)
(setf (q+:text channelname) ""))))
(define-slot (channel-list create) ()
(declare (connected create (clicked)))
(let ((name (q+:text channelname)))
(when (and (string/= "" name)
(channel channel-list))
(qsend (channel channel-list)
'lichat-protocol:create
:channel name)
(setf (q+:text channelname) ""))))
(defmethod update-listing ((channel-list channel-list))
(let ((list (slot-value channel-list 'list)))
(qui:clear-layout list T)
(dolist (channel (channels channel-list))
(qui:add-item channel list))))
(defmethod channel ((channel-list channel-list))
(qui:active-item (slot-value channel-list 'list)))
(defmethod (setf channel) ((channel null) (channel-list channel-list))
(setf (channels channel-list) NIL))
(defmethod (setf channel) ((channel channel) (channel-list channel-list))
(setf (qui:active-item (slot-value channel-list 'list)) channel))
(defmethod (setf channel) ((channel integer) (channel-list channel-list))
(let ((channel (find-channel channel channel-list)))
(when channel (setf (channel (main channel-list)) channel))))
(defmethod (setf channel) ((channel string) (channel-list channel-list))
(let ((channel (find-channel channel channel-list)))
(when channel (setf (channel (main channel-list)) channel))))
(defmethod find-channel ((name string) (channel-list channel-list))
(qui:find-item name (slot-value channel-list 'list) :key #'name :test #'string-equal))
(defmethod find-channel ((index integer) (channel-list channel-list))
(when (< index (length (channels channel-list)))
(qui:item-at index (slot-value channel-list 'list))))
(defmethod next-channel ((channel-list channel-list))
(let ((pos (qui:item-position (channel channel-list) (slot-value channel-list 'list))))
(when pos
(setf (channel channel-list)
(mod (1+ pos) (length (channels channel-list)))))))
(defmethod prev-channel ((channel-list channel-list))
(let ((pos (qui:item-position (channel channel-list) (slot-value channel-list 'list))))
(when pos
(setf (channel channel-list)
(mod (1- pos) (length (channels channel-list)))))))