1 
2 /******************************************************************************
3 * MODULE     : concat_active.cpp
4 * DESCRIPTION: Typeset active markup
5 * COPYRIGHT  : (C) 1999  Joris van der Hoeven
6 *******************************************************************************
7 * This software falls under the GNU general public license version 3 or later.
8 * It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
9 * in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
10 ******************************************************************************/
11 
12 #include "concater.hpp"
13 #include "file.hpp"
14 #include "image_files.hpp"
15 #include "sys_utils.hpp"
16 #include "analyze.hpp"
17 #include "scheme.hpp"
18 #include "packrat.hpp"
19 #include "convert.hpp"
20 
21 /******************************************************************************
22 * Typesetting executable markup
23 ******************************************************************************/
24 
25 void
typeset_if(tree t,path ip)26 concater_rep::typeset_if (tree t, path ip) {
27   // This method must be kept consistent with edit_env_rep::exec(tree)
28   // in ../Env/env_exec.cpp
29   if ((N(t)!=2) && (N(t)!=3)) {
30     typeset_executable (t, ip);
31     return;
32   }
33   tree tt= env->exec (t[0]);
34   if (is_compound (tt) || ! is_bool (tt->label)) {
35     typeset_executable (t, ip);
36     return;
37   }
38   marker (descend (ip, 0));
39   if (as_bool (tt->label)) typeset (t[1], descend (ip, 1));
40   else if (N(t) == 3) typeset (t[2], descend (ip, 2));
41   marker (descend (ip, 1));
42 }
43 
44 void
typeset_var_if(tree t,path ip)45 concater_rep::typeset_var_if (tree t, path ip) {
46   if (N(t) != 2) { typeset_error (t, ip); return; }
47   tree flag= env->exec (t[0]);
48   box  b   = typeset_as_concat (env, attach_right (t[1], ip));
49   marker (descend (ip, 0));
50   if (flag == "true") print (b);
51   else print (empty_box (b->ip, b->x1, b->y1, b->x2, b->y2));
52   marker (descend (ip, 1));
53 }
54 
55 void
typeset_case(tree t,path ip)56 concater_rep::typeset_case (tree t, path ip) {
57   // This method must be kept consistent with edit_env_rep::exec(tree)
58   // in ../Env/env_exec.cpp
59   if (N(t)<2) {
60     typeset_executable (t, ip);
61     return;
62   }
63   marker (descend (ip, 0));
64   int i, n= N(t);
65   for (i=0; i<(n-1); i+=2) {
66     tree tt= env->exec (t[i]);
67     if (is_compound (tt) || !is_bool (tt->label)) {
68       typeset_executable (t, ip);
69       i=n;
70     }
71     else if (as_bool (tt->label)) {
72       typeset (t[i+1], descend (ip, i+1));
73       i=n;
74     }
75   }
76   if (i<n) typeset (t[i], descend (ip, i));
77   marker (descend (ip, 1));
78 }
79 
80 /******************************************************************************
81 * Typesetting linking primitives
82 ******************************************************************************/
83 
84 bool
build_locus(edit_env env,tree t,list<string> & ids,string & col,string & ref,string & anchor)85 build_locus (edit_env env, tree t, list<string>& ids, string& col, string &ref, string &anchor) {
86   //cout << "Typeset " << t << "\n";
87   int last= N(t)-1;
88   tree body= env->expand (t[last], true);
89   //cout << "Typeset " << body << "\n";
90   bool accessible= is_accessible (obtain_ip (body));
91   bool visited= false;
92   ref= "";
93   anchor= "";
94 
95   if (!is_nil (env->link_env)) {
96     int i, j;
97     for (i=0; i<last; i++) {
98       tree arg= env->exec (t[i]);
99       if (is_compound (arg, "id", 1)) {
100 	string id= as_string (arg[0]);
101 	if (accessible) env->link_env->insert_locus (id, body);
102 	else if (N (obtain_ip (body)) > 1) {
103 	  extern tree get_subtree (path p);
104 	  path p= path_up (reverse (descend_decode (obtain_ip (body), 1)));
105 	  env->link_env->insert_locus ("&" * id, get_subtree (p));
106 	}
107 	ids= list<string> (id, ids);
108 	visited= visited || has_been_visited ("id:" * id);
109       }
110       else if (is_compound (arg, "link") && N(arg) >= 2) {
111 	if (is_func (arg[1], ATTR)) arg= copy (arg);
112 	else arg= arg (0, 1) * tree (LINK, tree (ATTR)) * arg (1, N(arg));
113 	arg[1] << tree ("secure")
114 	       << (env->secure? tree ("true"): tree ("false"));
115 	env->link_env->insert_link (arg);
116 	for (j=2; j<N(arg); j++) {
117 	  if (is_compound (arg[j], "id", 1) && is_atomic (arg[j][0])) {
118 	    visited= visited || has_been_visited ("id:" * arg[j][0]->label);
119 	    anchor = arg[j][0]->label;
120 	  }
121 	  if (is_compound (arg[j], "url", 1) && is_atomic (arg[j][0])) {
122 	    visited= visited || has_been_visited ("url:" * arg[j][0]->label);
123 	    ref = arg[j][0]->label;
124 	  }
125 	}
126       }
127       else if (is_compound (arg, "observer", 2)) {
128 	string id= as_string (arg[0]);
129 	string cb= cork_to_utf8 (as_string (arg[1]));
130 	if (accessible) {
131           if (env->secure ||
132               as_bool (eval ("(secure? '(" * cb * " #f #f #f))")))
133             env->link_env->insert_locus (id, body, cb);
134         }
135 	ids= list<string> (id, ids);
136 	visited= visited || has_been_visited ("id:" * id);
137       }
138     }
139   }
140 
141   bool on_paper= (env->get_string (PAGE_PRINTED) == "true");
142   bool preserve= (get_locus_rendering ("locus-on-paper") == "preserve");
143   string var= (visited? VISITED_COLOR: LOCUS_COLOR);
144   string current_col= env->get_string (COLOR);
145   string locus_col= env->get_string (var);
146   if (on_paper) visited= false;
147   if (locus_col == "preserve") col= current_col;
148   else if (on_paper && preserve) col= current_col;
149   else if (locus_col == "global") col= get_locus_rendering (var);
150   else col= locus_col;
151 
152   return accessible;
153 }
154 
155 bool
build_locus(edit_env env,tree t,list<string> & ids,string & col)156 build_locus (edit_env env, tree t, list<string>& ids, string& col) {
157   string ref;
158   string anchor;
159   return build_locus(env, t, ids, col, ref, anchor);
160 }
161 
162 void
typeset_locus(tree t,path ip)163 concater_rep::typeset_locus (tree t, path ip) {
164   string ref;
165   string anchor;
166 
167   if (N(t) == 0) { typeset_error (t, ip); return; }
168   int last= N(t)-1;
169   list<string> ids;
170   string col;
171   if (build_locus (env, t, ids, col, ref, anchor)) {
172     marker (descend (ip, 0));
173     tree old= env->local_begin (COLOR, col);
174     typeset (t[last], descend (ip, last));
175     env->local_end (COLOR, old);
176     marker (descend (ip, 1));
177   }
178   else {
179     tree old= env->local_begin (COLOR, col);
180     box b= typeset_as_concat (env, t[last], descend (ip, last));
181     env->local_end (COLOR, old);
182     print (locus_box (ip, b, ids, env->pixel, ref, anchor));
183   }
184 }
185 
186 void
typeset_set_binding(tree t,path ip)187 concater_rep::typeset_set_binding (tree t, path ip) {
188   tree keys= env->exec (t);
189   if (L(keys) == HIDDEN) {
190     keys= keys[0];
191     flag ("set binding", ip, blue);
192     if (N(keys) > 0) {
193       path sip= ip;
194       if (N(t) >= 3 && (!is_nil (env->macro_src))) {
195 	tree body= env->expand (tree (ARG, t[2]), true);
196 	sip= obtain_ip (body);
197       }
198       path dip= decorate_middle (sip);
199       box b= tag_box (dip, sip, empty_box (dip, 0, 0, 0, env->fn->yx), keys);
200       a << line_item (CONTROL_ITEM, OP_SKIP, b, HYPH_INVALID, "label");
201     }
202   }
203   else typeset_dynamic (keys, ip);
204 }
205 
206 static tree
remove_labels(tree t)207 remove_labels (tree t) {
208   if (is_atomic (t)) return copy (t);
209   else if (is_func (t, LABEL)) return "";
210   else if (is_func (t, CONCAT)) {
211     tree r (CONCAT);
212     for (int i=0; i<N(t); i++)
213       if (!is_func (t, LABEL))
214         r << remove_labels (t[i]);
215     if (N(r) == 0) return "";
216     else if (N(r) == 1) return r[0];
217     else return r;
218   }
219   else {
220     tree r (t, N(t));
221     for (int i=0; i<N(t); i++)
222       r[i]= remove_labels (t[i]);
223     return r;
224   }
225 }
226 
227 void
typeset_write(tree t,path ip)228 concater_rep::typeset_write (tree t, path ip) {
229   if (N(t) != 2) { typeset_error (t, ip); return; }
230   string s= env->exec_string (t[0]);
231   tree   r= remove_labels (env->exec (t[1]));
232   if (env->complete) {
233     if (!env->local_aux->contains (s))
234       env->local_aux (s)= tree (DOCUMENT);
235     env->local_aux (s) << r;
236   }
237   control ("write", ip);
238 }
239 
240 void
typeset_toc_notify(tree t,path ip)241 concater_rep::typeset_toc_notify (tree t, path ip) {
242   if (N(t) != 2) { typeset_error (t, ip); return; }
243   string kind = tree_to_verbatim (env->exec (t[0]), false, "cork");
244   string title= tree_to_verbatim (env->exec (t[1]), false, "cork");
245   title= replace (title, "T_EX_MACS", "TeXmacs");
246   title= replace (title, "L^AT_EX", "LaTeX");
247   title= replace (title, "T_EX", "TeX");
248   box  b = toc_box (decorate_middle (ip), kind, title, env->fn);
249   marker (descend (ip, 0));
250   print (b);
251   marker (descend (ip, 1));
252 }
253 
254 /******************************************************************************
255 * Typesetting other dynamic markup
256 ******************************************************************************/
257 
258 void
typeset_specific(tree t,path ip)259 concater_rep::typeset_specific (tree t, path ip) {
260   if (N(t) != 2) { typeset_error (t, ip); return; }
261   string which= env->exec_string (t[0]);
262   if (which == "texmacs" || which == "image") {
263     marker (descend (ip, 0));
264     typeset (t[1], descend (ip, 1));
265     marker (descend (ip, 1));
266     //typeset_dynamic (t[1], descend (ip, 1));
267   }
268   else if (which == "screen" || which == "printer" ||
269            which == "even" || which == "odd") {
270     box  sb= typeset_as_concat (env, attach_middle (t[1], ip));
271     box  b = specific_box (decorate_middle (ip), sb, which, env->fn);
272     marker (descend (ip, 0));
273     print (b);
274     marker (descend (ip, 1));
275   }
276   else control ("specific", ip);
277 }
278 
279 void
typeset_flag(tree t,path ip)280 concater_rep::typeset_flag (tree t, path ip) {
281   if (N(t) != 2 && N(t) != 3) { typeset_error (t, ip); return; }
282   string name= env->exec_string (t[0]);
283   string col = env->exec_string (t[1]);
284   path sip= ip;
285   if ((N(t) >= 3) && (!is_nil (env->macro_src))) {
286     string var= env->exec_string (t[2]);
287     sip= env->macro_src->item [var];
288   }
289   if (((N(t) == 2) || is_accessible (sip)) && (!env->read_only)) {
290     marker (descend (ip, 0));
291     flag_ok (name, ip, named_color (col));
292     marker (descend (ip, 1));
293   }
294 }
295 
296 /******************************************************************************
297 * Typesetting images
298 ******************************************************************************/
299 
300 #define error_image(t) { \
301   typeset_dynamic (tree (ERROR, "bad image", t), ip); \
302   return; \
303 }
304 
305 void
typeset_image(tree t,path ip)306 concater_rep::typeset_image (tree t, path ip) {
307   // determine the image url
308   if (N(t) != 5) error_image ("parameters");
309   tree image_tree= env->exec (t[0]);
310   url image= url_none ();
311   if (is_atomic (image_tree)) {
312     if (N (image_tree->label) == 0)
313       error_image (tree (WITH, "color", "red", "no image"));
314     url im= image_tree->label;
315     image= resolve (relative (env->base_file_name, im));
316     if (is_none (image)) image= "$TEXMACS_PATH/misc/pixmaps/unknown.ps";
317   }
318   else if (is_func (image_tree, TUPLE, 2) &&
319 	     is_func (image_tree[0], RAW_DATA, 1) &&
320 	     is_atomic (image_tree[0][0]) && is_atomic (image_tree[1])) {
321     image= url_ramdisc (image_tree[0][0]->label) *
322            url ("image." * image_tree[1]->label);
323   }
324   else error_image (image_tree);
325 
326   // determine the original size of the image
327   int iw, ih;
328   image_size (image, iw, ih);
329   double pt= ((double) env->dpi*PIXEL) / 72.0;
330   SI w= (SI) (((double) iw) * pt);
331   SI h= (SI) (((double) ih) * pt);
332 
333   // determine the width and the height
334   tree old_w= env->local_begin ("w-length", as_string (w) * "tmpt");
335   tree old_h= env->local_begin ("h-length", as_string (h) * "tmpt");
336   SI imw= (t[1] == ""? w: env->as_length (env->exec (t[1]), "w"));
337   SI imh= (t[2] == ""? h: env->as_length (env->exec (t[2]), "h"));
338   if (t[1] == "" && t[2] != "" && ih != 0)
339     imw= (SI) ((iw * ((double) imh)) / ih);
340   if (t[1] != "" && t[2] == "" && iw != 0)
341     imh= (SI) ((ih * ((double) imw)) / iw);
342   if (imw <= 0 || imh <= 0)
343     error_image (tree (WITH, "color", "red", "null box"));
344   env->local_end ("w-length", old_w);
345   env->local_end ("h-length", old_h);
346 
347   // determine the offset
348   old_w= env->local_begin ("w-length", as_string (imw) * "tmpt");
349   old_h= env->local_begin ("h-length", as_string (imh) * "tmpt");
350   SI imx= (t[3] == ""? 0: env->as_length (env->exec (t[3]), "w"));
351   SI imy= (t[4] == ""? 0: env->as_length (env->exec (t[4]), "h"));
352   env->local_end ("w-length", old_w);
353   env->local_end ("h-length", old_h);
354 
355   // print the box
356   box imb= image_box (ip, image, imw, imh, env->alpha, env->pixel);
357   print (move_box (ip, imb, imx, imy, true));
358 }
359 
360 #undef error_image
361