1 /* gEDA - GPL Electronic Design Automation
2 * gschem - gEDA Schematic Capture
3 * Copyright (C) 2010-2011 Peter Brett <peter@peter-b.co.uk>
4 *
5 * This program is free software; you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation; either version 2 of the License, or
8 * (at your option) any later version.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with this program; if not, write to the Free Software
17 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
18 */
19 #include <config.h>
20
21 #include "gschem.h"
22
23 SCM scheme_window_fluid = SCM_UNDEFINED;
24
25 scm_t_bits window_smob_tag;
26
27 /*! \brief Free a #GSCHEM_TOPLEVEL smob.
28 * \par Function Description
29 * Finalizes a window smob for deletion.
30 *
31 * Used internally to Guile
32 */
33 static size_t
smob_free(SCM smob)34 smob_free (SCM smob)
35 {
36 GSCHEM_TOPLEVEL *window = (GSCHEM_TOPLEVEL *) SCM_SMOB_DATA (smob);
37
38 /* If the weak ref has been cleared, do nothing */
39 if (window == NULL) return 0;
40
41 /* Otherwise, go away. */
42 window->smob = SCM_UNDEFINED;
43
44 return 0;
45 }
46
47 /*! \brief Print a representation of a #GSCHEM_TOPLEVEL smob.
48 * \par Function Description
49 * Outputs a string representing the \a smob to a Scheme output
50 * \a port. The format used is "#<gschem-window b7ef65d0>".
51 *
52 * Used internally to Guile.
53 */
54 static int
smob_print(SCM smob,SCM port,scm_print_state * pstate)55 smob_print (SCM smob, SCM port, scm_print_state *pstate)
56 {
57 gchar *hexstring;
58
59 scm_puts ("#<gschem-window", port);
60
61 scm_dynwind_begin (0);
62 hexstring = g_strdup_printf (" %zx", SCM_SMOB_DATA (smob));
63 scm_dynwind_unwind_handler (g_free, hexstring, SCM_F_WIND_EXPLICITLY);
64 scm_puts (hexstring, port);
65 scm_dynwind_end ();
66
67 scm_puts (">", port);
68
69 /* Non-zero means success */
70 return 1;
71 }
72
73 /*! \brief Get the smob for a #GSCHEM_TOPLEVEL.
74 * \par Function Description
75 * Return a smob representing \a window.
76 *
77 * \param window #GSCHEM_TOPLEVEL to obtain a smob for.
78 * \param a smob representing \a window.
79 */
80 SCM
g_scm_from_window(GSCHEM_TOPLEVEL * w_current)81 g_scm_from_window (GSCHEM_TOPLEVEL *w_current)
82 {
83 g_assert (w_current != NULL);
84
85 if (w_current->smob == SCM_UNDEFINED) {
86 SCM_NEWSMOB (w_current->smob, window_smob_tag, w_current);
87 }
88
89 return w_current->smob;
90 }
91
92 /*!
93 * \brief Set the #GSCHEM_TOPLEVEL fluid in the current dynamic context.
94 * \par Function Description
95 *
96 * This function must be used inside a pair of calls to
97 * scm_dynwind_begin() and scm_dynwind_end(). During the dynwind
98 * context, the #GSCHEM_TOPLEVEL fluid is set to \a w_current.
99 *
100 * \param [in] w_current The new GSCHEM_TOPLEVEL pointer.
101 */
102 void
g_dynwind_window(GSCHEM_TOPLEVEL * w_current)103 g_dynwind_window (GSCHEM_TOPLEVEL *w_current)
104 {
105 SCM window_s = g_scm_from_window (w_current);
106 scm_dynwind_fluid (scheme_window_fluid, window_s);
107 edascm_dynwind_toplevel (w_current->toplevel);
108 }
109
110 /*!
111 * \brief Get the value of the #GSCHEM_TOPLEVEL fluid.
112 * \par Function Description
113 * Return the value of the #GSCHEM_TOPLEVEL fluid in the current
114 * dynamic context.
115 */
116 SCM_DEFINE (current_window, "%current-window", 0, 0, 0,
117 (),
118 "Get the GSCHEM_TOPLEVEL for the current dynamic context.")
119 {
120 return scm_fluid_ref (scheme_window_fluid);
121 }
122
123 /*!
124 * \brief Get the value of the #GSCHEM_TOPLEVEL fluid.
125 * \par Function Description
126 * Return the value of the #GSCHEM_TOPLEVEL fluid in the current dynamic
127 * context.
128 */
129 GSCHEM_TOPLEVEL *
g_current_window()130 g_current_window ()
131 {
132 SCM window_s = current_window ();
133
134 if (!(SCM_SMOB_PREDICATE (window_smob_tag, window_s)
135 && ((void *)SCM_SMOB_DATA (window_s) != NULL))) {
136 scm_misc_error (NULL, _("Found invalid gschem window smob ~S"),
137 scm_list_1 (window_s));
138 }
139
140 return (GSCHEM_TOPLEVEL *) SCM_SMOB_DATA (window_s);
141 }
142
143 /*!
144 * \brief Get the active page.
145 * \par Function Description
146 * Returns the page which is active in the current gschem window. If
147 * there is no active page, returns SCM_BOOL_F.
148 *
149 * \note Scheme API: Implements the %active-page procedure in the
150 * (gschem core window) module.
151 *
152 * \return the active page.
153 */
154 SCM_DEFINE (active_page, "%active-page", 0, 0, 0,
155 (), "Get the active page.")
156 {
157 TOPLEVEL *toplevel = edascm_c_current_toplevel ();
158 if (toplevel->page_current != NULL) {
159 return edascm_from_page (toplevel->page_current);
160 } else {
161 return SCM_BOOL_F;
162 }
163 }
164
165 /*!
166 * \brief Set the active page.
167 * \par Function Description
168 * Sets the page which is active in the current gschem window to \a
169 * page_s.
170 *
171 * \note Scheme API: Implements the %set-active-page! procedure in the
172 * (gschem core window) module.
173 *
174 * \param page_s Page to switch to.
175 * \return \a page_s.
176 */
177 SCM_DEFINE (set_active_page_x, "%set-active-page!", 1, 0, 0,
178 (SCM page_s), "Set the active page.")
179 {
180 SCM_ASSERT (edascm_is_page (page_s), page_s, SCM_ARG1, s_set_active_page_x);
181
182 PAGE *page = edascm_to_page (page_s);
183 x_window_set_current_page (g_current_window (), page);
184
185 return page_s;
186 }
187
188 /*!
189 * \brief Close a page
190 * \par Function Description
191 * Closes the page \a page_s.
192 *
193 * \note Scheme API: Implements the %close-page! procedure in the
194 * (gschem core window) module. Overrides the %close-page! procedure
195 * in the (geda core page) module.
196 *
197 * \param page_s Page to close.
198 * \return SCM_UNDEFINED
199 */
200 SCM_DEFINE (override_close_page_x, "%close-page!", 1, 0, 0,
201 (SCM page_s), "Close a page.")
202 {
203 /* Ensure that the argument is a page smob */
204 SCM_ASSERT (edascm_is_page (page_s), page_s,
205 SCM_ARG1, s_override_close_page_x);
206
207 GSCHEM_TOPLEVEL *w_current = g_current_window ();
208 TOPLEVEL *toplevel = w_current->toplevel;
209 PAGE *page = edascm_to_page (page_s);
210
211 /* If page is not the current page, switch pages, then switch back
212 * after closing page. */
213 PAGE *curr_page = toplevel->page_current;
214 int reset_page = (page != curr_page);
215 if (reset_page)
216 x_window_set_current_page (w_current, page);
217
218 x_window_close_page (w_current, w_current->toplevel->page_current);
219
220 if (reset_page)
221 x_window_set_current_page (w_current, curr_page);
222
223 return SCM_UNDEFINED;
224 }
225
226 /*!
227 * \brief Get the current pointer position
228 * \par Function Description
229 * Returns the current mouse pointer position, expressed in world
230 * coordinates. If the pointer is outside the schematic drawing area,
231 * returns SCM_BOOL_F.
232 *
233 * The coordinates are returned as a cons:
234 *
235 * <code>(x . y)</code>
236 *
237 * \note Scheme API: Implements the %pointer-position procedure in the
238 * (gschem core window) module.
239 *
240 * \return The current pointer position, or SCM_BOOL_F.
241 */
242 SCM_DEFINE (pointer_position, "%pointer-position", 0, 0, 0,
243 (), "Get the current pointer position.")
244 {
245 int x, y;
246 GSCHEM_TOPLEVEL *w_current = g_current_window ();
247 if (x_event_get_pointer_position (w_current, FALSE, &x, &y)) {
248 return scm_cons (scm_from_int (x), scm_from_int (y));
249 }
250 return SCM_BOOL_F;
251 }
252
253 /*!
254 * \brief Snap a point to the snap grid.
255 * \par Function Description
256 * Snaps the point (\a x_s, \a y_s) to the snap grid, returning the
257 * snapped point position as a cons in the form:
258 *
259 * <code>(x . y)</code>
260 *
261 * This always snaps the given point to the grid, disregarding the
262 * current user snap settings.
263 *
264 * \note Scheme API: Implements the %snap-point procedure in the
265 * (gschem core window) module.
266 *
267 * \param x_s the x-coordinate of the point to be snapped to grid.
268 * \param y_s the y-coordinate of the point to be snapped to grid.
269 * \return the snapped coordinates.
270 */
271 SCM_DEFINE (snap_point, "%snap-point", 2, 0, 0,
272 (SCM x_s, SCM y_s), "Get the current snap grid size.")
273 {
274 SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG1, s_snap_point);
275 SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG2, s_snap_point);
276
277 /* We save and restore the current snap setting, because we want to
278 * *always* snap the requested cordinates. */
279 GSCHEM_TOPLEVEL *w_current = g_current_window ();
280 int save_snap = w_current->snap;
281 w_current->snap = SNAP_GRID;
282 int x = snap_grid (w_current, scm_to_int (x_s));
283 int y = snap_grid (w_current, scm_to_int (y_s));
284 w_current->snap = save_snap;
285
286 return scm_cons (scm_from_int (x), scm_from_int (y));
287 }
288
289 /*!
290 * \brief Create the (gschem core window) Scheme module
291 * \par Function Description
292 * Defines procedures in the (gschem core window) module. The module
293 * can be accessed using (use-modules (gschem core window)).
294 */
295 static void
init_module_gschem_core_window()296 init_module_gschem_core_window ()
297 {
298 /* Register the functions */
299 #include "g_window.x"
300
301 /* Add them to the module's public definitions. */
302 scm_c_export (s_current_window, s_active_page, s_set_active_page_x,
303 s_override_close_page_x, s_pointer_position,
304 s_snap_point, NULL);
305
306 /* Override procedures in the (geda core page) module */
307 {
308 SCM geda_page_module = scm_c_resolve_module ("geda core page");
309 SCM close_page_proc =
310 scm_variable_ref (scm_c_lookup (s_override_close_page_x));
311 scm_c_module_define (geda_page_module, "close-page!", close_page_proc);
312 }
313 }
314
315 /*!
316 * \brief Initialise the GSCHEM_TOPLEVEL manipulation procedures.
317 * \par Function Description
318
319 * Registers some Scheme procedures for working with #GSCHEM_TOPLEVEL
320 * smobs and creates the #GSCHEM_TOPLEVEL fluid. Should only be called
321 * by main_prog().
322 */
323 void
g_init_window()324 g_init_window ()
325 {
326 /* Register gEDA smob type */
327 window_smob_tag = scm_make_smob_type ("gschem-window", 0);
328 scm_set_smob_free (window_smob_tag, smob_free);
329 scm_set_smob_print (window_smob_tag, smob_print);
330
331 /* Create fluid */
332 scheme_window_fluid = scm_permanent_object (scm_make_fluid ());
333
334 /* Define the (gschem core window) module */
335 scm_c_define_module ("gschem core window",
336 init_module_gschem_core_window,
337 NULL);
338 }
339