"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "TeXmacs/progs/graphics/graphics-group.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-group.scm  (TeXmacs-1.99.4-src):graphics-group.scm  (TeXmacs-1.99.5-src)
skipping to change at line 19 skipping to change at line 19
;; ;;
;; This software falls under the GNU general public license version 3 or later. ;; This software falls under the GNU general public license version 3 or later.
;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>. ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(texmacs-module (graphics graphics-group) (texmacs-module (graphics graphics-group)
(:use (graphics graphics-env) (:use (graphics graphics-env)
(graphics graphics-single) (graphics graphics-single)
(kernel gui kbd-handlers))) (kernel gui kbd-handlers)
(dynamic animate-edit)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Group edit mode ;; Group edit mode
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; State ;; State
(define group-old-x #f) (define group-old-x #f)
(define group-old-y #f) (define group-old-y #f)
(define group-first-x #f) (define group-first-x #f)
(define group-first-y #f) (define group-first-y #f)
skipping to change at line 169 skipping to change at line 170
(set! graphics-undo-enabled #t) (set! graphics-undo-enabled #t)
(graphics-forget-states)))) (graphics-forget-states))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Copy and paste attribute style ;; Copy and paste attribute style
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(tm-define (graphics-assign-props p obj) (tm-define (graphics-assign-props p obj)
(let* ((l1 (graphics-all-attributes)) (let* ((l1 (graphics-all-attributes))
(l2 (map gr-prefix l1)) (l2 (map gr-prefix l1))
(l3 (map graphics-get-property l2)) (l3 (map (graphics-get-property-at p) l2))
(l4 (map cons l1 l3)) (l4 (map cons l1 l3))
(tab (list->ahash-table l4))) (tab (list->ahash-table l4)))
(graphics-remove p 'memoize-layer) (graphics-remove p 'memoize-layer)
(graphics-group-enrich-insert-table (stree-radical obj) tab #f))) (graphics-group-enrich-insert-table (stree-radical obj) tab #f)))
(tm-define (graphics-copy-props p) (tm-define (graphics-get-props p)
(let* ((t (path->tree p)) (and-with t (path->tree p)
(attrs (graphical-relevant-attributes t)) (let* ((attrs (graphical-relevant-attributes t))
(vars (list-difference attrs '("gid"))) (vars (list-difference attrs '("gid" "anim-id")))
(get-prop (lambda (var) (graphics-path-property p var))) (get-prop (lambda (var) (graphics-path-property p var)))
(gr-vars (map gr-prefix vars)) (gr-vars (map gr-prefix vars))
(vals (map get-prop vars))) (vals (map get-prop vars)))
(for-each graphics-set-property gr-vars vals))) (for-each graphics-set-property gr-vars vals))))
(tm-define (graphics-get-props-at-mouse)
(and-with p current-path
(graphics-get-props p)))
(define (with-list vars vals)
(cond ((or (null? vars) (null? vals)) (list))
((== (car vals) "default") (with-list (cdr vars) (cdr vals)))
(else (cons* (car vars) (car vals)
(with-list (cdr vars) (cdr vals))))))
(define (graphics-tree-apply-props t vars vals)
(with l (with-list vars vals)
(and-with w (tree-up t)
(if (tree-is? w 'with)
(if (null? l)
(tree-set! w (tm-ref w :last))
(tree-set! w `(with ,@l ,(tm-ref w :last))))
(if (null? l)
(noop)
(tree-set! t `(with ,@l ,t)))))))
(tm-define (graphics-apply-props p)
(and-with t (path->tree p)
(let* ((attrs (graphical-relevant-attributes t))
(vars (list-difference attrs '("gid" "anim-id")))
(gr-vars (map gr-prefix vars))
(vals (map graphics-get-property gr-vars)))
(graphics-tree-apply-props t vars vals))))
(tm-define (graphics-apply-props-at-mouse)
(and-with p current-path
(graphics-apply-props p)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Edit properties
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (has-attribute? t var)
(cond ((not (tree? t)) #f)
((tree-is? t 'anim-edit) (has-attribute? (tm-ref t 1) var))
((tree-in? t '(anim-static anim-dynamic))
(with c (or (graphics-anim-frames t) (list))
(list-or (map (cut has-attribute? <> var) c))))
((tree-is? t 'with) (has-attribute? (tm-ref t :last) var))
((tree-atomic? t) #f)
(else (graphics-attribute? (tree-label t) var))))
(tm-define (graphics-mode-attribute? mode var)
(:require (== (graphics-mode) '(group-edit edit-props)))
(with v (if (string-starts? var "gr-") (string-drop var 3) var)
(with l (map (cut has-attribute? <> v) (sketch-get))
(list-or l))))
(define (property-get t var i)
(cond ((not (tree? t)) "default")
((tree-is? t 'anim-edit) (property-get (tm-ref t 1) var 0))
((tree-in? t '(anim-static anim-dynamic))
(with c (or (graphics-anim-frames t) (list))
(properties-and (map (cut property-get <> var 0) c))))
((not (tree-is? t 'with)) "default")
((>= i (- (tree-arity t) 1)) "default")
((tm-equal? (tree-ref t i) var) (tree->stree (tree-ref t (+ i 1))))
(else (property-get t var (+ i 2)))))
(define (property-and p1 p2)
(if (== p1 p2) p1 "mixed"))
(tm-define (properties-and l)
(cond ((null? l) "default")
((null? (cdr l)) (car l))
(else (property-and (car l) (properties-and (cdr l))))))
(tm-define (graphics-get-property var)
(:require (and (== (graphics-mode) '(group-edit edit-props))
(graphics-selection-active?)))
(with v (if (string-starts? var "gr-") (string-drop var 3) var)
(if (graphics-mode-attribute? (graphics-mode) v)
(with l (map (cut property-get <> v 0) (sketch-get))
(properties-and l))
(former var))))
(define (property-remove t var i)
(cond ((>= i (- (tree-arity t) 1)) t)
((tm-equal? (tree-ref t i) var)
(if (== (tree-arity t) 3)
(tree-remove-node! t 2)
(tree-remove! t i 2))
t)
(else (property-remove t var (+ i 2)))))
(define (property-set-sub t var val i)
(cond ((>= i (- (tree-arity t) 1))
(tree-insert! t i (list var val))
t)
((tm-equal? (tree-ref t i) var)
(tree-set (tree-ref t (+ i 1)) val)
t)
(else (property-set-sub t var val (+ i 2)))))
(define (property-set t var val)
(cond ((not (tree? t)) t)
((tree-is? t 'anim-edit)
(property-set (tree-ref t 1) var val))
((tree-in? t '(anim-static anim-dynamic))
(with c (or (graphics-anim-frames t) (list))
(for-each (cut property-set <> var val) c)
t))
((tree-is? t 'with)
(if (== val "default")
(property-remove t var 0)
(property-set-sub t var val 0)))
((== val "default") t)
(else
(tree-set! t `(with ,var ,val ,t))
t)))
(tm-define (graphics-set-property var val)
(:require (and (== (graphics-mode) '(group-edit edit-props))
(graphics-selection-active?)))
(with v (if (string-starts? var "gr-") (string-drop var 3) var)
(if (graphics-mode-attribute? (graphics-mode) v)
(with r (map (cut property-set <> v val) (sketch-get))
(sketch-set! r))
(former var val))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Remove ;; Remove
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(tm-define (remove-selected-objects) (tm-define (remove-selected-objects)
(sketch-checkout) (sketch-checkout)
(sketch-reset) (sketch-reset)
(sketch-commit) (sketch-commit)
(graphics-group-start)) (graphics-group-start))
skipping to change at line 204 skipping to change at line 330
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; State transitions ;; State transitions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(tm-define (start-operation opn p obj) (tm-define (start-operation opn p obj)
(texmacs-error "start-operation" "invalid context")) (texmacs-error "start-operation" "invalid context"))
(tm-define (start-operation opn p obj) (tm-define (start-operation opn p obj)
(:require (graphical-non-group-tag? (car obj))) (:require (graphical-non-group-tag? (car obj)))
(set! current-path #f) (set! current-path #f)
(if sticky-point (if (not sticky-point)
;;Perform operation (set! preselected (nnull? (sketch-get))))
(begin (cond
(sketch-commit) ;;Perform operation
(graphics-decorations-update) (sticky-point
(if (== (state-ref graphics-first-state 'graphics-action) (sketch-commit)
'start-operation) (graphics-decorations-update)
(remove-undo-mark)) (if (== (state-ref graphics-first-state 'graphics-action)
(set! graphics-undo-enabled #t) 'start-operation)
(graphics-forget-states)) (remove-undo-mark))
;;Start operation (set! graphics-undo-enabled #t)
(cond (graphics-forget-states)
((and (not multiselecting) (eq? (cadr (graphics-mode)) 'group-ungroup)) (if (not preselected) (unselect-all p obj))
(if (and p (not sticky-point) (null? (sketch-get)) (set! preselected #f))
(== (tree-label (path->tree p)) 'gr-group)) ;;Start operation
(sketch-set! `(,(path->tree p)))) ((and (not multiselecting) (eq? (cadr (graphics-mode)) 'group-ungroup))
(if (and (not sticky-point) (if (and p (not sticky-point) (null? (sketch-get))
(== (length (sketch-get)) 1) (== (tree-label (path->tree p)) 'gr-group))
(== (tree-label (car (sketch-get))) 'gr-group)) (sketch-set! `(,(path->tree p))))
(ungroup-current-object) (if (and (not sticky-point)
(group-selected-objects))) (== (length (sketch-get)) 1)
((and (not multiselecting) (== (cadr (graphics-mode)) 'props)) (== (tree-label (car (sketch-get))) 'gr-group))
(if (null? (sketch-get)) (ungroup-current-object)
(if p (group-selected-objects)))
(begin ((and (not multiselecting) (== (cadr (graphics-mode)) 'props))
(set! obj (stree-at p)) (if (null? (sketch-get))
(set! current-path (graphics-assign-props p obj)) (if p
(set! current-obj obj)
(graphics-decorations-update)))
(with l '()
(for (o (sketch-get))
(with p (graphics-assign-props
(tree->path o)
(tree->stree o))
(set! l (cons (path->tree p) l))))
(sketch-set! (reverse l))
(graphics-decorations-update)))
(graphics-group-start))
((and (not multiselecting) (or p (nnull? (sketch-get))))
(if (null? (sketch-get))
(any_toggle-select #f #f p obj))
(if (store-important-points)
(begin (begin
(graphics-store-state 'start-operation) (set! obj (stree-at p))
(sketch-checkout) (set! current-path (graphics-assign-props p obj))
(sketch-transform tree->stree) (set! current-obj obj)
(set! group-first-go (copy-tree (sketch-get))) (graphics-decorations-update)))
(set! graphics-undo-enabled #f) (with l '()
(graphics-store-state #f) (for (o (sketch-get))
(set! group-old-x (s2f current-x)) (with p (graphics-assign-props
(set! group-old-y (s2f current-y)))))))) (tree->path o)
(tree->stree o))
(set! l (cons (path->tree p) l))))
(sketch-set! (reverse l))
(graphics-decorations-update)))
(graphics-group-start))
((and (not multiselecting) (or p (nnull? (sketch-get))))
(if (null? (sketch-get))
(any_toggle-select #f #f p obj))
(store-important-points) ;; ignore return value?
(graphics-store-state 'start-operation)
(sketch-checkout)
(sketch-transform tree->stree)
(set! group-first-go (copy-tree (sketch-get)))
(set! graphics-undo-enabled #f)
(graphics-store-state #f)
(set! group-old-x (s2f current-x))
(set! group-old-y (s2f current-y)))))
(define (any_toggle-select x y p obj) (define (any_toggle-select x y p obj)
(if (not sticky-point) (if (not sticky-point)
(if multiselecting (if multiselecting
(let* ((x1 (s2f selecting-x0)) (let* ((x1 (s2f selecting-x0))
(y1 (s2f selecting-y0)) (y1 (s2f selecting-y0))
(x2 (s2f x)) (x2 (s2f x))
(y2 (s2f y)) (y2 (s2f y))
(tmp 0) (tmp 0)
(sel #f)) (sel #f))
skipping to change at line 297 skipping to change at line 425
(begin (begin
(set! selecting-x0 x) (set! selecting-x0 x)
(set! selecting-y0 y) (set! selecting-y0 y)
(set! multiselecting #t)))))) (set! multiselecting #t))))))
(tm-define (toggle-select x y p obj) (tm-define (toggle-select x y p obj)
(texmacs-error "toggle-select" "invalid context")) (texmacs-error "toggle-select" "invalid context"))
(tm-define (toggle-select x y p obj) (tm-define (toggle-select x y p obj)
(:require (graphical-non-group-tag? (car obj))) (:require (graphical-non-group-tag? (car obj)))
(when (list? p)
(and-with t (path->tree p)
(tree-go-to t :end)))
(any_toggle-select x y p obj)) (any_toggle-select x y p obj))
(define (any_unselect-all p obj) (define (any_unselect-all p obj)
(cond ((nnull? (sketch-get)) (cond ((nnull? (sketch-get))
(sketch-reset) (sketch-reset)
(graphics-decorations-update)) (graphics-decorations-update))
((and p (not multiselecting) (== (cadr (graphics-mode)) 'props)) ((and p (not multiselecting) (== (cadr (graphics-mode)) 'props))
(graphics-copy-props p)))) (graphics-get-props p))))
(tm-define (unselect-all p obj) (tm-define (unselect-all p obj)
(texmacs-error "unselect-all" "invalid context")) (texmacs-error "unselect-all" "invalid context"))
(tm-define (unselect-all p obj) (tm-define (unselect-all p obj)
(:require (graphical-non-group-tag? (car obj))) (:require (graphical-non-group-tag? (car obj)))
(any_unselect-all p obj)) (any_unselect-all p obj))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Global dispatching ;; Global dispatching
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(tm-define (edit_move mode x y) (tm-define (edit_move mode x y)
(:require (eq? mode 'group-edit)) (:require (eq? mode 'group-edit))
(:state graphics-state) (:state graphics-state)
(if sticky-point (cond (sticky-point
(begin (set! x (s2f x))
(set! x (s2f x)) (set! y (s2f y))
(set! y (s2f y)) (with mode (graphics-mode)
(with mode (graphics-mode) (cond ((== (cadr mode) 'move)
(cond ((== (cadr mode) 'move) (sketch-transform
(sketch-transform (group-translate (- x group-old-x)
(group-translate (- x group-old-x) (- y group-old-y))))
(- y group-old-y)))) ((== (cadr mode) 'zoom)
((== (cadr mode) 'zoom) (sketch-set! group-first-go)
(sketch-set! group-first-go) (sketch-transform (group-zoom x y)))
(sketch-transform (group-zoom x y))) ((== (cadr mode) 'rotate)
((== (cadr mode) 'rotate) (sketch-set! group-first-go)
(sketch-set! group-first-go) (sketch-transform (group-rotate x y)))))
(sketch-transform (group-rotate x y))))) (set! group-old-x x)
(set! group-old-x x) (set! group-old-y y))
(set! group-old-y y)) (multiselecting
(if multiselecting (graphical-object!
(begin (append
(graphical-object! (create-graphical-props 'default #f)
(append `((with color red
(create-graphical-props 'default #f) (cline (point ,selecting-x0 ,selecting-y0)
`((with color red (point ,x ,selecting-y0)
(cline (point ,selecting-x0 ,selecting-y0) (point ,x ,y)
(point ,x ,selecting-y0) (point ,selecting-x0 ,y)))))))
(point ,x ,y) (else
(point ,selecting-x0 ,y))))))) (cond (current-path
(graphics-decorations-update)))) (set-message (string-append "Left click: operate; "
"Right click: select/unselect")
"Group of objects"))
((nnull? (sketch-get))
(set-message "Left click: operate"
"Group of objects"))
(else
(set-message "Move over object on which to operate"
"Edit groups of objects")))
(graphics-decorations-update))))
(tm-define (edit_move mode x y) (tm-define (edit_move mode x y)
(:require (and (== mode 'edit) (current-in? '(gr-group)))) (:require (and (== mode 'edit) (current-in? '(gr-group))))
(:state graphics-state) (:state graphics-state)
(if sticky-point (if sticky-point
(display* "Uncaptured graphical move " mode ", " x ", " y "\n") (display* "Uncaptured graphical move " mode ", " x ", " y "\n")
(begin (begin
(set! current-point-no #f) (set! current-point-no #f)
(graphics-decorations-update)))) (graphics-decorations-update))))
(tm-define (edit_left-button mode x y) (tm-define (edit_left-button mode x y)
(:require (eq? mode 'group-edit)) (:require (eq? mode 'group-edit))
(:state graphics-state) (:state graphics-state)
(start-operation 'move current-path current-obj)) (start-operation 'move current-path current-obj))
(tm-define (edit_left-button mode x y)
(:require (in? (graphics-mode) '((group-edit edit-props)
(group-edit animate))))
(:state graphics-state)
(if (and (not current-path) (graphics-selection-active?))
(unselect-all current-path current-obj)
(begin
(unselect-all current-path current-obj)
(toggle-select x y current-path current-obj))))
(tm-define (edit_right-button mode x y) (tm-define (edit_right-button mode x y)
(:require (eq? mode 'group-edit)) (:require (eq? mode 'group-edit))
(:state graphics-state) (:state graphics-state)
(toggle-select x y current-path current-obj)) (if (and (not current-path) (graphics-selection-active?))
(unselect-all current-path current-obj)
(toggle-select x y current-path current-obj)))
(tm-define (edit_middle-button mode x y) (tm-define (edit_middle-button mode x y)
(:require (eq? mode 'group-edit)) (:require (eq? mode 'group-edit))
(:state graphics-state) (:state graphics-state)
(if (!= (logand (get-keyboard-modifiers) ShiftMask) 0) (if (!= (logand (get-keyboard-modifiers) ShiftMask) 0)
(if (null? (sketch-get)) (if (null? (sketch-get))
(middle-button) (graphics-delete)
(remove-selected-objects)) (remove-selected-objects))
(unselect-all current-path current-obj))) (unselect-all current-path current-obj)))
(tm-define (edit_tab-key mode inc) (tm-define (edit_tab-key mode inc)
(:require (eq? mode 'group-edit)) (:require (eq? mode 'group-edit))
;;(display* "Graphics] Group-edit(Tab)\n") ;;(display* "Graphics] Group-edit(Tab)\n")
(edit_tab-key 'edit inc)) (edit_tab-key 'edit inc))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Don't act on ;; Don't act on
 End of changes. 11 change blocks. 
91 lines changed or deleted 243 lines changed or added

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