1;;These abbreviations are very convenient
 2;;to use. A nice naming scheme is :
 3;;
 4;;  -> b=bool ;
 5;;  -> i=integer ;
 6;;  -> f=float ;
 7;;  -> sy=symbol ;
 8;;  -> s=string ;
 9;;  -> o=Scheme object ;
10;;  -> p=path.
11;;  -> t=tree.
12;;
13;;  One can add the missing ones on demand.
14(tm-define f2s float->string)
15(tm-define s2f string->float)
16(tm-define sy2s symbol->string)
17(tm-define s2sy string->symbol)
18(tm-define o2s object->string)
19(tm-define s2o string->object)
20(tm-define t2o tree->object)
21(tm-define o2t object->tree)

1(cond ((== (cadr mode) 'move)
2                  (sketch-transform
3                   (group-translate (- x group-old-x)
4                                    (- y group-old-y))))

1(tm-define (sketch-transform opn)
2  (set! the-sketch (map opn the-sketch))
3  (set! current-obj
4	(if (graphics-group-mode? (graphics-mode)) '(nothing) #f))
5  (set! current-path #f)
6  (graphics-decorations-update))

1(define (group-translate x y)
2  (lambda (o)
3    (traverse-transform o (translate-point x y))))

 1(define (traverse-transform o opn)
 2  (define (traverse o)
 3    (opn (if (pair? o) (map traverse o) o)))
 4  (traverse o))
 5
 6(define (translate-point x y)
 7  (lambda (o)
 8    (if (match? o '(point :%2))
 9	`(point ,(f2s (+ x (s2f (cadr o)))) ,(f2s (+ y (s2f (caddr o)))))
10        o)))

1(define-public (tm-ref t . l)
2  (and (tm? t)
3       (with r (select t l)
4	 (and (nnull? r) (car r)))))

1  tmscm_install_procedure ("tm?", contentP, 1, 0, 0);

1tmscm
2contentP (tmscm t) {
3  bool b= tmscm_is_content (t);
4  return bool_to_tmscm (b);
5}

 1bool
 2tmscm_is_content (tmscm p) {
 3  if (tmscm_is_string (p) || tmscm_is_tree (p)) return true;
 4  else if (!tmscm_is_pair (p) || !tmscm_is_symbol (tmscm_car (p))) return false;
 5  else {
 6    for (p= tmscm_cdr (p); !tmscm_is_null (p); p= tmscm_cdr (p))
 7      if (!tmscm_is_pair (p) || !tmscm_is_content (tmscm_car (p))) return false;
 8    return true;
 9  }
10}

1Scheme]  (tm? '(point 1 2))
2
3#f
4Scheme]  (tm? (stree->tree '(point 1 2)))
5
6#t

1Scheme]  (tm-ref (stree->tree '(1 2 3 4)) 0)
2
32

 1  (assuming (style-has? "std-markup-dtd")
 2    (with u '(arrow-with-text arrow-with-text*)
 3      (with l (list-filter u (lambda (s) (style-has? (symbol->string s))))
 4        (for (tag (sort l symbol<=?))
 5          ((eval (upcase-first (symbol->string tag)))
 6           (import-from (graphics graphics-markup))
 7           (graphics-set-mode `(edit ,tag))))))
 8    (with u (list-difference gr-tags-user '(arrow-with-text arrow-with-text*))
 9      (with l (list-filter u (lambda (s) (style-has? (symbol->string s))))
10        (assuming (nnull? l)
11          ---
12          (for (tag (sort l symbol<=?))
13            ((eval (upcase-first (symbol->string tag)))
14             (import-from (graphics graphics-markup))
15             (graphics-set-mode `(edit ,tag))))))))

 1if (N(p) == 0)
 2      typeset_dynamic (tree (ERROR, "bad text-at"), ip);
 3    else {
 4      SI ox= (SI) p[0], oy= (SI) p[1], axis= (b->h() >> 1), x= ox, y= oy;
 5      if (halign == "left") x -= b->x1;
 6      else if (halign == "center") x -= ((b->x1 + b->x2) >> 1);
 7      else if (halign == "right") x -= b->x2;
 8      if (valign == "bottom") y -= b->y1;
 9      else if (valign == "axis") {
10        axis= env->fn->yfrac - b->y1;
11        y -= env->fn->yfrac;
12      }
13      else if (valign == "center") y -= ((b->y1 + b->y2) >> 1);
14      else if (valign == "top") y -= b->y2;
15      SI snap= env->get_length (TEXT_AT_SNAPPING);
16      print (text_at_box (ip, b, x, y, ox - x, oy - y, axis, snap));
17      SI pad = env->text_at_repulse;
18      if (pad >= 0)
19        env->white_zones << rectangle (x + b->x1 - pad, y + b->y1 - pad,
20                                       x + b->x2 + pad, y + b->y2 + pad);
21    }

 1(tm-define (edit_left-button mode x y)
 2  (:require (== mode 'edit))
 3  (:state graphics-state)
 4  (display "graphics-single 377\n")
 5  (display* sticky-point "\n")
 6  (display* (current-in? (graphical-text-tag-list)) "\n")
 7  (set-texmacs-pointer 'graphics-cross)
 8  (cond (sticky-point
 9         (if (current-in? (graphical-text-tag-list))
10             (object_commit)
11             (next-point)))
12        ((and (current-in? (graphical-text-tag-list))
13              (== (car (graphics-mode)) 'edit)
14              (graphical-contains-text-tag? (cadr (graphics-mode)))
15              (not (graphical-contains-curve-tag? (cadr (graphics-mode))))
16              (pointer-inside-graphical-text?))
17         (set-texmacs-pointer 'text-arrow)
18         (go-to (car (select-first (s2f current-x) (s2f current-y)))))
19        (else
20         (edit-insert x y)
21         (display* "HERE\n")))
22  (set! previous-leftclick `(point ,current-x ,current-y)))

1(define (edit-insert x y)
2  (edit-clean-up)
3  (object_create (cadr (graphics-mode)) x y))

 1(tm-define (object_create tag x y)
 2  (texmacs-error "object-create" "invalid tag"))
 3
 4(tm-define (object_create tag x y)
 5  (:require (== tag 'point))
 6  (object-set! `(point ,x ,y) 'new))
 7
 8(tm-define (object_create tag x y)
 9  (:require (or (in? tag gr-tags-curves) (in? tag gr-tags-user)))
10  (with o (graphics-enrich `(,tag (point ,x ,y) (point ,x ,y)))
11    (graphics-store-state 'start-create)
12    (set! current-point-no 1)
13    (object-set! o 'checkout)
14    (graphics-store-state #f)))
15
16(tm-define (object_create tag x y)
17  (:require (graphical-text-tag? tag))
18  (with long? (graphical-long-text-tag? tag)
19    (object-set! `(,tag ,(if long? `(document "") "") (point ,x ,y)) 'new)
20    (and-with d (path->tree (cDr (cursor-path)))
21      (when (tree-func? d 'document)
22        (tree-go-to d 0 :start)))))

1(tm-define (object_create tag x y)
2  (:require (graphical-text-tag? tag))
3  (display* "HERE\n")
4  (with long? (graphical-long-text-tag? tag)
5    (object-set! `(,tag ,(if long? `(document "") "") (point ,x ,y)) 'new)
6    (and-with d (path->tree (cDr (cursor-path)))
7      (when (tree-func? d 'document)
8        (tree-go-to d 0 :start)))))

1(tm-define (graphics-group-enrich-insert t)
2  (graphics-group-insert (graphics-enrich t)))

1(tm-define (graphics-enrich t)
2  (let* ((l1 (graphics-all-attributes))
3         (l2 (map gr-prefix l1))
4         (l3 (map graphics-get-property l2))
5         (tab (list->ahash-table (map cons l1 l3))))
6    (graphics-enrich-bis t "default" tab)))

1(tm-define (graphics-enrich-bis t id tab)
2  (set! tab (list->ahash-table (ahash-table->list tab)))
3  (ahash-remove! tab "gid")
4  (let* ((attrs (graphical-relevant-attributes t))
5         (sel (ahash-table-select tab attrs))
6         (l1 (cons (cons "gid" id) (ahash-table->list sel)))
7         (l2 (map (lambda (x) (list (car x) (cdr x))) l1)))
8    ;;(display* "l= " l2 "\n")
9    (graphics-enrich-sub t l2)))

1class concater_rep {
2  edit_env              env;        // the environment
3  array<line_item>      a;          // the line items
4  bool                  rigid;      // when surely not wrappable

1(tm-define (object-set-text-at-halign val)
2  (:argument val "Horizontal alignment")
3  (:check-mark "*" (object-test-property? "text-at-halign"))
4  (object-set-property "text-at-halign" val))

1(tm-define (object-set-property var val)
2  (and-with t (tree-innermost graphical-context?)
3    (object-set-property-bis t var val)))

1(define (object-set-property-bis t var val)
2  (cond ((tree-is? t :up 'with)
3         (with-set (tree-up t) var val 0))
4        ((!= val "default")
5         (tree-set! t `(with ,var ,val ,t)))))

1(tm-menu (text-at-halign-menu)
2  ("Center" (object-set-text-at-halign "default"))
3  ("Right" (object-set-text-at-halign "right"))
4  ("Left1111" (object-set-text-at-halign "left")))

1(tm-define-macro (tm-menu head . l)
2  (receive (opts body) (list-break l not-define-option?)
3    `(tm-define ,head ,@opts (menu-dynamic ,@body))))

1(tm-define-macro (menu-dynamic . l)
2  `($list ,@(map gui-make l)))

 1(tm-define (gui-make x)
 2  ;;(display* "x= " x "\n")
 3  (cond ((symbol? x)
 4         (cond ((== x '---) '$---)
 5               ((== x '===) (gui-make '(glue #f #f 0 5)))
 6               ((== x '======) (gui-make '(glue #f #f 0 15)))
 7               ((== x '/) '$/)
 8               ((== x '//) (gui-make '(glue #f #f 5 0)))
 9               ((== x '///) (gui-make '(glue #f #f 15 0)))
10               ((== x '>>) (gui-make '(glue #t #f 5 0)))
11               ((== x '>>>) (gui-make '(glue #t #f 15 0)))
12               ((== x (string->symbol "|")) '$/)
13               (else
14                 (texmacs-error "gui-make" "invalid menu item ~S" x))))
15        ((string? x) x)
16        ((and (pair? x) (ahash-ref gui-make-table (car x)))
17         (apply (car (ahash-ref gui-make-table (car x))) (list x)))
18        ((and (pair? x) (or (string? (car x)) (pair? (car x))))
19         `($> ,(gui-make (car x)) ,@(cdr x)))
20        (else
21          (texmacs-error "gui-make" "invalid menu item ~S" x))))

1(tm-define (object-set-text-at-halign val)
2  (:argument val "Horizontal alignment")
3  (:check-mark "*" (object-test-property? "text-at-halign"))
4  (object-set-property "text-at-halign" val))

1(define (object-test-property? var)
2  (lambda (val)
3    (if (== val "default") (set! val (tree->stree (get-init-tree var))))
4    (== (object-get-property var) val)))

1{
2                scm_name = "get-init-tree",
3                cpp_name = "get_init_value",
4                ret_type = "tree",
5                arg_list = {
6                    "string"
7                }
8            },

 1tree
 2edit_typeset_rep::get_init_value (string var) {
 3  if (init->contains (var)) {
 4    tree t= init [var];
 5    if (var == BG_COLOR && is_func (t, PATTERN)) t= env->exec (t);
 6    return is_func (t, BACKUP, 2)? t[0]: t;
 7  }
 8  if (N(pre)==0) typeset_preamble ();
 9  tree t= pre [var];
10  if (var == BG_COLOR && is_func (t, PATTERN)) t= env->exec (t);
11  return is_func (t, BACKUP, 2)? t[0]: t;
12}

1class edit_typeset_rep: virtual public editor_rep {
2protected:
3  tree the_style;                         // document style
4  hashmap<path,hashmap<string,tree> > cur; // environment at different paths
5  hashmap<string,tree> stydef;            // environment after styles
6  hashmap<string,tree> pre;               // environment after styles and init
7  hashmap<string,tree> init;              // environment changes w.r.t. style

 1void
 2edit_typeset_rep::set_init (hashmap<string,tree> H) {
 3  init= hashmap<string,tree> (UNINIT);
 4  add_init (H);
 5}
 6
 7void
 8edit_typeset_rep::add_init (hashmap<string,tree> H) {
 9  init->join (H);
10  ::notify_assign (ttt, path(), subtree (et, rp));
11  notify_change (THE_ENVIRONMENT);
12}

 1void
 2edit_typeset_rep::set_data (new_data data) {
 3  set_style (data->style);
 4  set_init  (data->init);
 5  set_fin   (data->fin);
 6  set_ref   (data->ref);
 7  set_aux   (data->aux);
 8  set_att   (data->att);
 9  notify_page_change ();
10  add_init (data->init);
11  notify_change (THE_DECORATIONS);
12  typeset_invalidate_env ();
13  iterator<string> it = iterate (data->att);
14  while (it->busy()) {
15    string key= it->next ();
16    (void) call (string ("notify-set-attachment"),
17                 buf->buf->name, key, data->att [key]);
18  }
19}

1void
2set_buffer_data (url name, new_data data) {
3  array<url> vs= buffer_to_views (name);
4  for (int i=0; i<N(vs); i++) {
5    view_to_editor (vs[i]) -> set_data (data);
6    view_to_editor (vs[i]) -> init_update ();
7  }
8}

 1void
 2set_buffer_tree (url name, tree doc) {
 3  tm_buffer buf= concrete_buffer (name);
 4  if (is_nil (buf)) {
 5    insert_buffer (name);
 6    buf= concrete_buffer (name);
 7    tree body= detach_data (doc, buf->data);
 8    set_document (buf->rp, body);
 9    buf->buf->title= propose_title (buf->buf->title, name, body);
10    if (buf->data->project != "") {
11      url prj_name= head (name) * as_string (buf->data->project);
12      buf->prj= concrete_buffer_insist (prj_name);
13    }
14  }
15  else {
16    string old_title= buf->buf->title;
17    string old_project= buf->data->project->label;
18    tree body= detach_data (doc, buf->data);
19    assign (buf->rp, body);
20    set_buffer_data (name, buf->data);
21    buf->buf->title= propose_title (old_title, name, body);
22    if (buf->data->project != "" && buf->data->project != old_project) {
23      url prj_name= head (name) * as_string (buf->data->project);
24      buf->prj= concrete_buffer_insist (prj_name);
25    }
26  }
27  pretend_buffer_saved (name);
28}

1tm_buffer
2concrete_buffer (url name) {
3  int i, n= N(bufs);
4  for (i=0; i<n; i++)
5    if (bufs[i]->buf->name == name)
6      return bufs[i];
7  return nil_buffer ();
8}

 1class tm_buffer_rep {
 2public:
 3  new_buffer buf;         // file related information
 4  new_data data;          // data associated to document
 5  array<tm_view> vws;     // views attached to buffer
 6  tm_buffer prj;          // buffer which corresponds to the project
 7  path rp;                // path to the document's root in the_et
 8  link_repository lns;    // global links
 9  bool notify;            // notify modifications to scheme
10
11  inline tm_buffer_rep (url name):
12    buf (name), data (),
13    vws (0), prj (NULL), rp (new_document ()), notify (false) {}
14
15  inline ~tm_buffer_rep () {
16    delete_document (rp); }
17
18  void attach_notifier ();
19  bool needs_to_be_saved ();
20  bool needs_to_be_autosaved ();
21};

1url temp= get_current_view_safe ();
2  set_current_view (abstract_view (vw));
3  if (is_none (tm_init_buffer_file))
4    tm_init_buffer_file= "$TEXMACS_PATH/progs/init-buffer.scm";
5  if (is_none (my_init_buffer_file))
6    my_init_buffer_file= "$TEXMACS_HOME_PATH/progs/my-init-buffer.scm";
7  if (exists (tm_init_buffer_file)) exec_file (tm_init_buffer_file);
8  if (exists (my_init_buffer_file)) exec_file (my_init_buffer_file);
9  set_current_view (temp);

1(tm-define (object-get-property var)
2  (tree->stree (get-env-tree var)))

1{
2                scm_name = "get-env-tree",
3                cpp_name = "get_env_value",
4                ret_type = "tree",
5                arg_list = {
6                    "string"
7                }
8            },

 1tree
 2edit_typeset_rep::get_env_value (string var, path p) {
 3  typeset_exec_until (p);
 4  tree t= cur[p][var];
 5  return is_func (t, BACKUP, 2)? t[0]: t;
 6}
 7
 8tree
 9edit_typeset_rep::get_env_value (string var) {
10 /* FIXME: tp is wrong (and consequently, crashes TeXmacs)
11  *   when we call this routine from inside the code which
12  *   is triggered by a button, for example.
13  *
14  * Test: fire TeXmacs, then open a new Graphics, then click
15  *   on the icon for going in spline mode. Then it crashes,
16  *   because we call (get-env-tree) from inside the Scheme.
17  *   If we call (get-env-tree-at ... (cDr (cursor-path))),
18  *   then it works.
19  */
20  return get_env_value (var, tp);
21}