"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "TeXmacs/progs/graphics/graphics-single.scm" between
TeXmacs-1.99.4-src.tar.gz and TeXmacs-1.99.5-src.tar.gz

About: GNU TeXmacs is a what-you-see-is-what-you-get scientific text editor, which was both inspired by TeX and GNU Emacs.

graphics-single.scm  (TeXmacs-1.99.4-src):graphics-single.scm  (TeXmacs-1.99.5-src)
skipping to change at line 75 skipping to change at line 75
(tm-define (object_create tag x y) (tm-define (object_create tag x y)
(:require (or (in? tag gr-tags-curves) (in? tag gr-tags-user))) (:require (or (in? tag gr-tags-curves) (in? tag gr-tags-user)))
(with o (graphics-enrich `(,tag (point ,x ,y) (point ,x ,y))) (with o (graphics-enrich `(,tag (point ,x ,y) (point ,x ,y)))
(graphics-store-state 'start-create) (graphics-store-state 'start-create)
(set! current-point-no 1) (set! current-point-no 1)
(object-set! o 'checkout) (object-set! o 'checkout)
(graphics-store-state #f))) (graphics-store-state #f)))
(tm-define (object_create tag x y) (tm-define (object_create tag x y)
(:require (graphical-text-tag? tag)) (:require (graphical-text-tag? tag))
(object-set! `(,tag "" (point ,x ,y)) 'new)) (with long? (graphical-long-text-tag? tag)
(object-set! `(,tag ,(if long? `(document "") "") (point ,x ,y)) 'new)
(and-with d (path->tree (cDr (cursor-path)))
(when (tree-func? d 'document)
(tree-go-to d 0 :start)))))
(define (set-point-sub obj no x y) (define (set-point-sub obj no x y)
;;(display* "set-point-sub " obj ", " no ", " x ", " y "\n") ;;(display* "set-point-sub " obj ", " no ", " x ", " y "\n")
(cond ((== (car obj) 'with) (cond ((== (car obj) 'with)
(set-point-sub (cAr obj) no x y)) (set-point-sub (cAr obj) no x y))
((== (car obj) 'point) ((== (car obj) 'point)
(set-car! (cdr obj) x) (set-car! (cdr obj) x)
(set-car! (cddr obj) y)) (set-car! (cddr obj) y))
((and (not (not no)) (list? obj) (> (length obj) (+ no 1))) ((and (not (not no)) (list? obj) (> (length obj) (+ no 1)))
(set-point-sub (list-ref obj (+ no 1)) #f x y)) (set-point-sub (list-ref obj (+ no 1)) #f x y))
skipping to change at line 137 skipping to change at line 141
(graphics-remove current-path)) (graphics-remove current-path))
;; Basic operations (checkout & commit) ;; Basic operations (checkout & commit)
(define (object_checkout) (define (object_checkout)
(sketch-set! `(,(path->tree current-path))) (sketch-set! `(,(path->tree current-path)))
(sketch-checkout) (sketch-checkout)
;;(display* "Checked out " (sketch-get) "\n") ;;(display* "Checked out " (sketch-get) "\n")
(sketch-set! (map tree->stree (sketch-get)))) (sketch-set! (map tree->stree (sketch-get))))
(define (object_commit) (define (object_commit)
(define obj (stree-radical (car (sketch-get1)))) (let* ((compl (car (sketch-get1)))
(if (not (graphics-incomplete? obj)) (obj (stree-radical compl)))
(with (xobj xp) (graphics-complete obj) (if (not (graphics-incomplete? obj))
(set! obj xobj) (with (xobj xp) (graphics-complete obj)
(with tab (make-ahash-table) (set! obj xobj)
(for (var (graphics-all-attributes)) (with tab (make-ahash-table)
(when (nin? var '("gid")) (for (var (graphics-all-attributes))
(ahash-set! tab var (ahash-ref graphical-attrs var)))) (when (nin? var '("gid"))
(graphical-fetch-props (car (sketch-get))) (ahash-set! tab var (ahash-ref graphical-attrs var))))
(set! obj (graphics-enrich-bis (graphical-fetch-props (car (sketch-get)))
obj (ahash-ref graphical-attrs "gid") tab)) (for (var (list "anim-id"))
(set! current-edge-sel? #f) (ahash-set! tab var (ahash-ref graphical-attrs var)))
(sketch-set! `(,obj)) (set! obj (graphics-enrich-bis
;;(display* "Commited " (sketch-get) "\n") obj (ahash-ref graphical-attrs "gid") tab))
(sketch-commit) (set! obj (graphics-re-enhance obj compl #f))
(set! leftclick-waiting #f) (set! current-edge-sel? #f)
(set! current-obj (stree-radical obj)) (sketch-set! `(,obj))
(set! current-point-no #f) ;;(display* "Commited " (sketch-get) "\n")
(graphics-forget-states)))) (sketch-commit)
(delayed (set! leftclick-waiting #f)
(graphics-update-constraints))) (set! current-obj (stree-radical obj))
(set! current-point-no #f)
(graphics-forget-states))))
(delayed
(graphics-update-constraints))))
(tm-define (current-in? l) (tm-define (current-in? l)
(and (pair? current-obj) (in? (car current-obj) l))) (and (pair? current-obj) (in? (car current-obj) l)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Updating the constraints ;; Updating the constraints
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tree-update-constraints t) (define (tree-update-constraints t)
(cond ((not (tree? t)) (noop)) (cond ((not (tree? t)) (noop))
skipping to change at line 207 skipping to change at line 215
(define previous-leftclick #f) (define previous-leftclick #f)
(define (hardly-moved?) (define (hardly-moved?)
(and previous-leftclick (and previous-leftclick
(points-dist< (points-dist<
previous-leftclick previous-leftclick
`(point ,current-x ,current-y) `(point ,current-x ,current-y)
moveclick-tolerance))) moveclick-tolerance)))
(define (move-over) (define (move-over)
(set-message "Left click: new object; Drag: edit object; Middle click: remove" (set-message (string-append "Left click: new object; "
"") "Drag: edit object; "
"Right click: remove; "
"Return: apply properties; "
"S-Return: fetch properties")
"Mouse over object")
(graphics-decorations-update) (graphics-decorations-update)
(if current-path (if current-path
(with p2 (tm-upwards-path current-path (with p2 (tm-upwards-path current-path
(graphical-text-tag-list) '(graphics)) (graphical-text-tag-list) '(graphics))
(if (not p2) (go-to (rcons current-path 0)))))) (if (not p2) (go-to (rcons current-path 0))))))
(define (edit-clean-up) (define (edit-clean-up)
;; remove cruft which uncareful editing may create ;; remove cruft which uncareful editing may create
(with-innermost t 'graphics (with-innermost t 'graphics
(for (i (reverse (.. 0 (tree-arity t)))) (for (i (reverse (.. 0 (tree-arity t))))
skipping to change at line 252 skipping to change at line 265
(if (and leftclick-waiting (not (hardly-moved?))) (if (and leftclick-waiting (not (hardly-moved?)))
(begin (begin
(set! leftclick-waiting #f) (set! leftclick-waiting #f)
(object_add-point (object_add-point
current-point-no current-point-no
(cadr previous-leftclick) (caddr previous-leftclick) (cadr previous-leftclick) (caddr previous-leftclick)
current-x current-y current-x current-y
(== (logand (get-keyboard-modifiers) ShiftMask) 0))) (== (logand (get-keyboard-modifiers) ShiftMask) 0)))
(begin (begin
(if leftclick-waiting (if leftclick-waiting
(set-message "Left click: finish; Middle click: undo" "") (set-message "Left click: finish; Right click: undo"
(set-message "Left click: add point; Middle click: undo" "")) "Inserting control points")
(set-message "Left click: add point; Right click: undo"
"Inserting control points"))
(object_set-point current-point-no current-x current-y))) (object_set-point current-point-no current-x current-y)))
(graphics-decorations-update)) (graphics-decorations-update))
(define (last-point) (define (last-point)
(object_set-point current-point-no current-x current-y) (object_set-point current-point-no current-x current-y)
(object_commit)) (object_commit))
(define (next-point) (define (next-point)
(cond ((not (hardly-moved?)) (cond ((not (hardly-moved?))
(set-message "Left click: finish; Middle click: undo" "") (set-message "Left click: finish; Right click: undo"
"Inserting control points")
(set! leftclick-waiting #t)) (set! leftclick-waiting #t))
(leftclick-waiting (leftclick-waiting
(last-point)) (last-point))
((== current-point-no 1) ((== current-point-no 1)
(undo 0) (undo 0)
(set! leftclick-waiting #f)) (set! leftclick-waiting #f))
(else (else
(set-message "Left click: finish; Middle click: undo" "") (set-message "Left click: finish; Right click: undo"
"Inserting control points")
(graphics-back-state #f) (graphics-back-state #f)
(graphics-move current-x current-y) (graphics-move current-x current-y)
(set! leftclick-waiting #t)))) (set! leftclick-waiting #t))))
(define (remove-point) (define (remove-point)
(if (or (graphics-minimal? current-obj) (if (or (graphics-minimal? current-obj)
(not (current-in? gr-tags-all)) (not (current-in? gr-tags-all))
(!= (logand (get-keyboard-modifiers) ShiftMask) 0)) (!= (logand (get-keyboard-modifiers) ShiftMask) 0))
(begin (begin
(object_remove) (object_remove)
(graphics-decorations-reset) (graphics-decorations-reset)
(graphics-group-start)) (graphics-group-start))
(begin (begin
(object_remove-point current-point-no) (object_remove-point current-point-no)
(graphics-decorations-update)))) (graphics-decorations-update))))
;; Middle button ;; Middle button
(tm-define (middle-button) (tm-define (graphics-delete)
(if sticky-point (if sticky-point
(begin (begin
(graphics-back-state #f) (graphics-back-state #f)
(graphics-move current-x current-y)) (graphics-move current-x current-y))
(remove-point))) (remove-point)))
(tm-define (graphics-update-decorations) (tm-define (graphics-update-decorations)
(:state graphics-state) (:state graphics-state)
(if current-obj (graphics-decorations-update))) (if current-obj (graphics-decorations-update)))
skipping to change at line 348 skipping to change at line 365
(:state graphics-state) (:state graphics-state)
(set-texmacs-pointer 'graphics-cross #t) (set-texmacs-pointer 'graphics-cross #t)
(if current-obj (if current-obj
(begin (begin
(if (current-in? (graphical-text-tag-list)) (if (current-in? (graphical-text-tag-list))
(set! current-point-no 1)) (set! current-point-no 1))
(if sticky-point (if sticky-point
(move-point) (move-point)
(move-over))) (move-over)))
(begin (begin
(set-message "Left click: new object" "") (set-message "Left click: new object" "Graphics")
(graphics-decorations-reset)))) (graphics-decorations-reset))))
(define (inside-graphical-text?) (define (pointer-inside-graphical-text?)
(and-with l (select-first (s2f current-x) (s2f current-y)) (and-with l (select-first (s2f current-x) (s2f current-y))
(and-with p (and (nnull? l) (car l)) (and-with p (and (nnull? l) (car l))
(and-with t (path->tree (cDr p)) (and-with t (path->tree (cDr p))
(not (tree-in? t '(text-at math-at))))))) (not (tree-in? t '(text-at math-at document-at)))))))
(tm-define (edit_left-button mode x y) (tm-define (edit_left-button mode x y)
(:require (== mode 'edit)) (:require (== mode 'edit))
(:state graphics-state) (:state graphics-state)
(set-texmacs-pointer 'graphics-cross) (set-texmacs-pointer 'graphics-cross)
(cond (sticky-point (cond (sticky-point
(if (current-in? (graphical-text-tag-list)) (if (current-in? (graphical-text-tag-list))
(object_commit) (object_commit)
(next-point))) (next-point)))
((and (current-in? (graphical-text-tag-list)) ((and (current-in? (graphical-text-tag-list))
(== (car (graphics-mode)) 'edit) (== (car (graphics-mode)) 'edit)
(graphical-contains-text-tag? (cadr (graphics-mode))) (graphical-contains-text-tag? (cadr (graphics-mode)))
(not (graphical-contains-curve-tag? (cadr (graphics-mode)))) (not (graphical-contains-curve-tag? (cadr (graphics-mode))))
(inside-graphical-text?)) (pointer-inside-graphical-text?))
(set-texmacs-pointer 'text-arrow) (set-texmacs-pointer 'text-arrow)
(go-to (car (select-first (s2f current-x) (s2f current-y))))) (go-to (car (select-first (s2f current-x) (s2f current-y)))))
(else (else
(edit-insert x y))) (edit-insert x y)))
(set! previous-leftclick `(point ,current-x ,current-y))) (set! previous-leftclick `(point ,current-x ,current-y)))
(tm-define (edit_middle-button mode x y) (tm-define (edit_middle-button mode x y)
(:require (== mode 'edit)) (:require (== mode 'edit))
(:state graphics-state) (:state graphics-state)
(set-texmacs-pointer 'graphics-cross) (set-texmacs-pointer 'graphics-cross)
(when current-obj (when current-obj
(middle-button))) (graphics-delete)))
(tm-define (edit_right-button mode x y)
(:require (== mode 'edit))
(:state graphics-state)
(set-texmacs-pointer 'graphics-cross)
(when current-obj
(graphics-delete)))
(tm-define (edit_start-drag mode x y) (tm-define (edit_start-drag mode x y)
(:require (== mode 'edit)) (:require (== mode 'edit))
(:state graphics-state) (:state graphics-state)
(set-texmacs-pointer 'graphics-cross) (set-texmacs-pointer 'graphics-cross)
(set! dragging-busy? #t) (set! dragging-busy? #t)
(set! dragging-create? (or sticky-point (not current-obj))) (set! dragging-create? (or sticky-point (not current-obj)))
(if (or sticky-point current-obj) (if (or sticky-point current-obj)
(begin (begin
(if (current-in? (graphical-text-tag-list)) (if (current-in? (graphical-text-tag-list))
skipping to change at line 403 skipping to change at line 427
(if sticky-point (if sticky-point
(next-point) (next-point)
(start-move))) (start-move)))
(edit-insert x y)) (edit-insert x y))
(set! previous-leftclick `(point ,current-x ,current-y))) (set! previous-leftclick `(point ,current-x ,current-y)))
(tm-define (edit_drag mode x y) (tm-define (edit_drag mode x y)
(:require (== mode 'edit)) (:require (== mode 'edit))
(:state graphics-state) (:state graphics-state)
(edit_move mode x y) (edit_move mode x y)
(set-message "Release left button: finish editing" "")) (set-message "Release left button: finish editing" "Dragging"))
(tm-define (edit_end-drag mode x y) (tm-define (edit_end-drag mode x y)
(:require (== mode 'edit)) (:require (== mode 'edit))
(:state graphics-state) (:state graphics-state)
(when dragging-busy? (when dragging-busy?
(set-texmacs-pointer 'graphics-cross) (set-texmacs-pointer 'graphics-cross)
(if (or sticky-point current-obj) (if (or sticky-point current-obj)
(if dragging-create? (if dragging-create?
(edit_move mode x y) (edit_move mode x y)
(last-point))) (last-point)))
skipping to change at line 428 skipping to change at line 452
(tm-define (edit_tab-key mode inc) (tm-define (edit_tab-key mode inc)
(:require (== mode 'edit)) (:require (== mode 'edit))
(:state graphics-state) (:state graphics-state)
(if (and current-x current-y) (if (and current-x current-y)
(begin (begin
(select-next inc) (select-next inc)
(graphics-update-decorations)) (graphics-update-decorations))
(invalidate-graphical-object))) (invalidate-graphical-object)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Hand drawn objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(tm-define (edit_move mode x y)
(:require (== mode 'hand-edit))
(:state graphics-state)
(noop))
(tm-define (edit_left-button mode x y)
(:require (== mode 'hand-edit))
(:state graphics-state)
(set-texmacs-pointer 'graphics-cross)
(edit-clean-up)
(object-set! `(with "point style" "disk"
"point-size" ,(graphics-get-property "line-width")
(point ,x ,y)) 'new))
(tm-define (edit_start-drag mode x y)
(:require (== mode 'hand-edit))
(:state graphics-state)
(set-texmacs-pointer 'graphics-cross)
(edit-clean-up)
(object_create (cadr (graphics-mode)) x y))
(tm-define (edit_drag mode x y)
(:require (== mode 'hand-edit))
(:state graphics-state)
(let* ((obj (car (sketch-get1)))
(rad (stree-radical obj)))
(set-cdr! rad (append (cdr rad) (list `(point ,x ,y))))
(object-set! obj))
(graphics-decorations-update))
(tm-define (edit_end-drag mode x y)
(:require (== mode 'hand-edit))
(:state graphics-state)
(object_commit)
(graphics-decorations-reset))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Don't dispatch certain actions on textual arguments of graphical macros ;; Don't dispatch certain actions on textual arguments of graphical macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (edit-macro-arg? mode) (define (edit-macro-arg? mode)
(and (== mode 'edit) (and (== mode 'edit)
(graphical-text-arg-context? current-obj))) (graphical-text-arg-context? current-obj)))
(tm-define (edit_middle-button mode x y) (tm-define (edit_middle-button mode x y)
(:require (edit-macro-arg? mode)) (:require (edit-macro-arg? mode))
(:state graphics-state) (:state graphics-state)
 End of changes. 14 change blocks. 
35 lines changed or deleted 98 lines changed or added

Home  |  About  |  All  |  Newest  |  Fossies Dox  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTPS