1 /* Part of XPCE --- The SWI-Prolog GUI toolkit
2
3 Author: Jan Wielemaker and Anjo Anjewierden
4 E-mail: jan@swi.psy.uva.nl
5 WWW: http://www.swi.psy.uva.nl/projects/xpce/
6 Copyright (c) 1985-2002, University of Amsterdam
7 All rights reserved.
8
9 Redistribution and use in source and binary forms, with or without
10 modification, are permitted provided that the following conditions
11 are met:
12
13 1. Redistributions of source code must retain the above copyright
14 notice, this list of conditions and the following disclaimer.
15
16 2. Redistributions in binary form must reproduce the above copyright
17 notice, this list of conditions and the following disclaimer in
18 the documentation and/or other materials provided with the
19 distribution.
20
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32 POSSIBILITY OF SUCH DAMAGE.
33 */
34
35 #include <h/kernel.h>
36 #include <h/graphics.h>
37
38 forwards status XcloseCursor(CursorObj, DisplayObj);
39
40 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
41 Creating cursors.
42
43 In X, cursors can be created two ways: from the cursor font and from
44 two pixmaps. PCE supports both ways to create a cursor. For this
45 reason various instantiation patterns for cursors exist.
46
47 ?- new(C, cursor(Name))
48 Create cursor from cursor font
49 ?- new(C, cursor(Name, Source, [Mask], [X, Y]
50 Create cursor from an image. If Mask is not supplied it defaults
51 to Source. If X and Y are not supplied they default to (0,0) This
52 function is in the first place meant to maintain compatibility with
53 the SunView version of cursors.
54
55 Cursors from now on are shared objects like fonts. That is, a second
56 `new' to a cursor of the same name returns the same cursor object.
57 This because they are limited resources on the X-server.
58 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
59
60 static status
initialiseCursor(CursorObj c,Name name,Image image,Image mask,Point hot,Colour foreground,Colour background)61 initialiseCursor(CursorObj c, Name name,
62 Image image, Image mask,
63 Point hot,
64 Colour foreground, Colour background)
65 { assign(c, name, name);
66
67 if ( isDefault(image) )
68 { if ( !ws_cursor_font_index(name) )
69 return errorPce(NAME_noNamedCursor, name);
70
71 assign(c, font_id, DEFAULT);
72 } else
73 { if ( isDefault(mask) )
74 { if ( notNil(image->mask) )
75 mask = image->mask;
76 else
77 mask = image;
78 }
79 if ( isDefault(hot) )
80 hot = newObject(ClassPoint, EAV);
81 if ( notNil(image->hot_spot) )
82 copyPoint(hot, image->hot_spot);
83
84 assign(c, image, image);
85 assign(c, mask, mask);
86 assign(c, hot_spot, hot);
87 assign(c, foreground, foreground);
88 assign(c, background, background);
89 }
90
91 if ( notNil(name) )
92 { Name assoc = getAppendName(c->name, NAME_Cursor);
93
94 protectObject(c);
95 newAssoc(assoc, c);
96
97 appendHashTable(CursorTable, c->name, c);
98 }
99
100 succeed;
101 }
102
103
104 static status
unlinkCursor(CursorObj c)105 unlinkCursor(CursorObj c)
106 { XcloseCursor(c, DEFAULT);
107
108 succeed;
109 }
110
111
112 static CursorObj
getLookupCursor(Class class,Name name)113 getLookupCursor(Class class, Name name)
114 { answer(getMemberHashTable(CursorTable, name));
115 }
116
117
118 static status
XopenCursor(CursorObj c,DisplayObj d)119 XopenCursor(CursorObj c, DisplayObj d)
120 { return ws_create_cursor(c, d);
121 }
122
123
124 static status
XcloseCursor(CursorObj c,DisplayObj d)125 XcloseCursor(CursorObj c, DisplayObj d)
126 { ws_destroy_cursor(c, d);
127
128 succeed;
129 }
130
131
132 static CursorObj
getConvertCursor(Class class,Name name)133 getConvertCursor(Class class, Name name)
134 { CursorObj c;
135
136 if ( (c = getMemberHashTable(CursorTable, name)) )
137 answer(c);
138 if ( syntax.uppercase &&
139 (c = getMemberHashTable(CursorTable, CtoKeyword(strName(name)))) )
140 answer(c);
141
142 return answerObject(ClassCursor, name, EAV);
143 }
144
145
146 /*******************************
147 * CLASS DECLARATION *
148 *******************************/
149
150 /* Type declarations */
151
152 static char *T_initialise[] =
153 { "name=name*", "image=[image]", "mask=[image]", "hot_spot=[point]", "foreground=[colour]", "background=[colour]" };
154
155 /* Instance Variables */
156
157 static vardecl var_cursor[] =
158 { IV(NAME_name, "name*", IV_GET,
159 NAME_name, "Name of the cursor"),
160 IV(NAME_fontId, "[int]*", IV_GET,
161 NAME_appearance, "Id in X-cursor font"),
162 IV(NAME_image, "image*", IV_GET,
163 NAME_appearance, "User-defined image"),
164 IV(NAME_mask, "image*", IV_GET,
165 NAME_appearance, "User-defined mask"),
166 IV(NAME_hotSpot, "point*", IV_GET,
167 NAME_appearance, "User-defined hot spot"),
168 IV(NAME_foreground, "[colour]*", IV_GET,
169 NAME_appearance, "Foreground colour of the cursor"),
170 IV(NAME_background, "[colour]*", IV_GET,
171 NAME_appearance, "Background colour of the cursor")
172 };
173
174 /* Send Methods */
175
176 static senddecl send_cursor[] =
177 { SM(NAME_initialise, 6, T_initialise, initialiseCursor,
178 DEFAULT, "Create from name or name, image, mask, hot_spot"),
179 SM(NAME_unlink, 0, NULL, unlinkCursor,
180 DEFAULT, "Destroy the cursor"),
181 SM(NAME_Xclose, 1, "display", XcloseCursor,
182 NAME_x, "Destroy X-cursor on display"),
183 SM(NAME_Xopen, 1, "display", XopenCursor,
184 NAME_x, "Create X-cursor on display")
185 };
186
187 /* Get Methods */
188
189 static getdecl get_cursor[] =
190 { GM(NAME_convert, 1, "cursor", "name", getConvertCursor,
191 NAME_conversion, "Convert cursor-name to cursor"),
192 GM(NAME_lookup, 1, "cursor", "name", getLookupCursor,
193 NAME_oms, "Lookup from @cursors table")
194 };
195
196 /* Resources */
197
198 #define rc_cursor NULL
199 /*
200 static classvardecl rc_cursor[] =
201 {
202 };
203 */
204
205 /* Class Declaration */
206
207 static Name cursor_termnames[] = { NAME_name };
208
209 ClassDecl(cursor_decls,
210 var_cursor, send_cursor, get_cursor, rc_cursor,
211 1, cursor_termnames,
212 "$Rev$");
213
214
215 status
makeClassCursor(Class class)216 makeClassCursor(Class class)
217 { declareClass(class, &cursor_decls);
218
219 cloneStyleClass(class, NAME_none);
220 CursorTable = globalObject(NAME_cursors, ClassHashTable, toInt(32), EAV);
221 ws_init_cursor_font();
222
223 succeed;
224 }
225
226
227