"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "TeXmacs/progs/graphics/graphics-object.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-object.scm  (TeXmacs-1.99.4-src):graphics-object.scm  (TeXmacs-1.99.5-src)
skipping to change at line 146 skipping to change at line 146
(if (== prop "magnify") (if (== prop "magnify")
(graphics-eval-magnify-at (rcons mode 0)) (graphics-eval-magnify-at (rcons mode 0))
(graphics-path-property mode prop))) (graphics-path-property mode prop)))
((== mode 'new) ((== mode 'new)
(graphics-get-property (string-append "gr-" prop))) (graphics-get-property (string-append "gr-" prop)))
(else ;;(== mode 'default) (else ;;(== mode 'default)
(get-default-val (string-append "gr-" prop)))) (get-default-val (string-append "gr-" prop))))
(dv prop res))) (dv prop res)))
(tm-define (create-graphical-props mode ps0) (tm-define (create-graphical-props mode ps0)
;;(display* "create-graphical-props " mode ", " ps0 "\n")
(let ((tab (make-ahash-table)) (let ((tab (make-ahash-table))
(l (graphics-all-attributes))) (l (graphics-all-attributes)))
(set! l (list-difference l '("gid"))) (set! l (list-difference l '("gid" "anim-id")))
(cond (cond
((== mode 'active) ((== mode 'active)
(for (var l) (for (var l)
(ahash-set! tab var (ahash-ref graphical-attrs var)))) (ahash-set! tab var (ahash-ref graphical-attrs var))))
((list? mode) ((list? mode)
(for (var l) (for (var l)
(ahash-set! tab var (graphics-path-property mode var))) (ahash-set! tab var (graphics-path-property mode var)))
(ahash-set! tab "magnify" (ahash-set! tab "magnify"
(graphics-eval-magnify-at (rcons mode 0)))) (graphics-eval-magnify-at (rcons mode 0))))
((== mode 'new) ((== mode 'new)
skipping to change at line 174 skipping to change at line 175
(with ps (ahash-ref tab "point-style") (with ps (ahash-ref tab "point-style")
(ahash-set! tab "point-style" (ahash-set! tab "point-style"
(if ps0 ps0 (if ps (dv "point-style" ps) "square")))) (if ps0 ps0 (if ps (dv "point-style" ps) "square"))))
(let* ((l1 (ahash-table->list tab)) (let* ((l1 (ahash-table->list tab))
(l2 (map (lambda (x) (list (car x) (dv (car x) (cdr x)))) l1)) (l2 (map (lambda (x) (list (car x) (dv (car x) (cdr x)))) l1))
(l3 (apply append l2))) (l3 (apply append l2)))
(cons 'with l3)))) (cons 'with l3))))
;; Graphical contours ;; Graphical contours
;;NOTE: This subsection is OK. ;;NOTE: This subsection is OK.
(define (create-graphical-embedding-box o ha0 va0 halign valign mag) (define (create-graphical-embedding-box o ha0 va0 halign valign w hm pp mag)
(define (create-text-at-handle o) (define (create-text-at-handle o)
(cond ((func? o 'with) (cond ((func? o 'with)
(create-text-at-handle (cAr o))) (create-text-at-handle (cAr o)))
((graphical-text-at-context? o) ((graphical-text-at-context? o)
`((with "point-style" "disk" `((with "point-style" "disk"
,(cAr o)))) ,(cAr o))))
(else '()))) (else '())))
(let* ((o1 (with res (if (or (graphical-text-at-context? o) (let* ((o1 (with res (if (or (graphical-text-at-context? o)
(== (car o) 'gr-group)) (== (car o) 'gr-group))
`(with "text-at-halign" ,ha0 `(with "text-at-halign" ,ha0
"text-at-valign" ,va0 ,o) ,(graphics-valign-var o) ,va0
"doc-at-width" ,w
"doc-at-hmode" ,hm
"doc-at-ppsep" ,pp ,o)
o) o)
`(with "magnify" ,(if (== mag "default") "1" mag) ,res))) `(with "magnify" ,(if (== mag "default") "1" mag) ,res)))
(info0 (cdr (box-info o1 "lbLB"))) (info0 (cdr (box-info o1 "lbLB")))
(info1 (cdr (box-info o1 "rtRT"))) (info1 (cdr (box-info o1 "rtRT")))
(l (f2s (min (s2f (car info0)) (s2f (caddr info0))))) (l (f2s (min (s2f (car info0)) (s2f (caddr info0)))))
(b (f2s (min (s2f (cadr info0)) (s2f (cadddr info0))))) (b (f2s (min (s2f (cadr info0)) (s2f (cadddr info0)))))
(r (f2s (max (s2f (car info1)) (s2f (caddr info1))))) (r (f2s (max (s2f (car info1)) (s2f (caddr info1)))))
(t (f2s (max (s2f (cadr info1)) (s2f (cadddr info1))))) (t (f2s (max (s2f (cadr info1)) (s2f (cadddr info1)))))
(p0 (frame-inverse `(tuple ,l ,b))) (p0 (frame-inverse `(tuple ,l ,b)))
(p1 (frame-inverse `(tuple ,r ,b))) (p1 (frame-inverse `(tuple ,r ,b)))
skipping to change at line 215 skipping to change at line 219
(with res `((cline ,p0 ,p1 ,p2 ,p3)) (with res `((cline ,p0 ,p1 ,p2 ,p3))
(set! res (append res (create-text-at-handle o))) (set! res (append res (create-text-at-handle o)))
res))) res)))
(define (in-interval? x i1 i2 supop infop) (define (in-interval? x i1 i2 supop infop)
(and (supop x i1) (infop x i2))) (and (supop x i1) (infop x i2)))
(tm-define (on-graphical-embedding-box? x y o eps) (tm-define (on-graphical-embedding-box? x y o eps)
(set! eps (length-decode eps)) (set! eps (length-decode eps))
(let* ((ha (get-graphical-prop 'basic "text-at-halign")) (let* ((ha (get-graphical-prop 'basic "text-at-halign"))
(va (get-graphical-prop 'basic "text-at-valign")) (va (get-graphical-prop 'basic (graphics-valign-var o)))
(o1 (if (graphical-text-at-context? o) (o1 (if (graphical-text-at-context? o)
`(with "text-at-halign" ,ha `(with "text-at-halign" ,ha
"text-at-valign" ,va ,o) ,(graphics-valign-var o) ,va ,o)
o)) o))
(info0 (cdr (box-info o1 "lbLB"))) (info0 (cdr (box-info o1 "lbLB")))
(info1 (cdr (box-info o1 "rtRT"))) (info1 (cdr (box-info o1 "rtRT")))
(l (min (s2f (car info0)) (s2f (caddr info0)))) (l (min (s2f (car info0)) (s2f (caddr info0))))
(b (min (s2f (cadr info0)) (s2f (cadddr info0)))) (b (min (s2f (cadr info0)) (s2f (cadddr info0))))
(r (max (s2f (car info1)) (s2f (caddr info1)))) (r (max (s2f (car info1)) (s2f (caddr info1))))
(t (max (s2f (cadr info1)) (s2f (cadddr info1)))) (t (max (s2f (cadr info1)) (s2f (cadddr info1))))
(p (frame-direct `(tuple ,x ,y)))) (p (frame-direct `(tuple ,x ,y))))
(set! x (s2f (cadr p))) (set! x (s2f (cadr p)))
(set! y (s2f (caddr p))) (set! y (s2f (caddr p)))
(or (and (in-interval? x (- l eps) l >= <) (or (and (in-interval? x (- l eps) l >= <)
(in-interval? y (- b eps) (+ t eps) >= <=)) (in-interval? y (- b eps) (+ t eps) >= <=))
(and (in-interval? x r (+ r eps) > <=) (and (in-interval? x r (+ r eps) > <=)
(in-interval? y (- b eps) (+ t eps) >= <=)) (in-interval? y (- b eps) (+ t eps) >= <=))
(and (in-interval? x (- l eps) (+ r eps) >= <=) (and (in-interval? x (- l eps) (+ r eps) >= <=)
(in-interval? y (- b eps) b >= <)) (in-interval? y (- b eps) b >= <))
(and (in-interval? x (- l eps) (+ r eps) >= <=) (and (in-interval? x (- l eps) (+ r eps) >= <=)
(in-interval? y t (+ t eps) > <=))))) (in-interval? y t (+ t eps) > <=)))))
(define draw-nonsticky-curp #t) (define draw-nonsticky-curp #t)
(define (create-graphical-contour o edge no) ;; Point mode (define (create-graphical-contour* o edge no) ;; Point mode
(define (curp lp) (define (curp lp)
(if draw-nonsticky-curp lp '())) (if draw-nonsticky-curp lp '()))
;;(display* "Contour for " o "\n")
(cond ((== (car o) 'point) (cond ((== (car o) 'point)
(cons o '())) (cons o '()))
((graphical-text-at-context? o) ((graphical-text-at-context? o)
(let* ((ha (get-graphical-prop 'basic "text-at-halign")) (let* ((ha (get-graphical-prop 'basic "text-at-halign"))
(va (get-graphical-prop 'basic "text-at-valign")) (va (get-graphical-prop 'basic (graphics-valign-var o)))
(w (get-graphical-prop 'basic "doc-at-width"))
(hm (get-graphical-prop 'basic "doc-at-hmode"))
(pp (get-graphical-prop 'basic "doc-at-ppsep"))
(mag (get-graphical-prop 'basic "magnify"))) (mag (get-graphical-prop 'basic "magnify")))
(create-graphical-embedding-box o ha va ha va mag))) (create-graphical-embedding-box o ha va ha va w hm pp mag)))
((== (car o) 'gr-group) ((== (car o) 'gr-group)
(let* ((ha (get-graphical-prop 'basic "text-at-halign")) (let* ((ha (get-graphical-prop 'basic "text-at-halign"))
(va (get-graphical-prop 'basic "text-at-valign")) (va (get-graphical-prop 'basic "text-at-valign"))
(mag (get-graphical-prop 'basic "magnify"))) (mag (get-graphical-prop 'basic "magnify")))
(create-graphical-embedding-box (create-graphical-embedding-box
o ha va "center" "center" mag))) o ha va "center" "center" "1par" "min" "0fn" mag)))
(else (if (integer? no) ((in? (car o) '(anim-edit))
(let* ((l (list-tail (cdr o) no)) (create-graphical-contour* (caddr o) 0 #f))
(ll (length l))) ((in? (car o) '(anim-static anim-dynamic))
(append (let* ((a (or (graphics-anim-frames o) (list (cadr o))))
(with h (list-head (cdr o) no) (c (map (lambda (x) (create-graphical-contour* x 0 #f)) a)))
(if (and edge (map (lambda (x) `(concat ,@x)) c)))
(in? (car o) ((== (car o) 'with)
'(cline cspline carc)) (create-graphical-contour* (cAr o) 0 #f))
(== (+ no 1) (length (cdr o)))) ((integer? no)
(cons `(with "point-style" (let* ((l (list-tail (cdr o) no))
,(if sticky-point (ll (length l)))
"square" "disk") (append
,(car h)) (cdr h)) (with h (list-head (cdr o) no)
h)) (if (and edge
(cons (in? (car o) (graphical-closed-curve-tag-list))
(list 'with "point-style" "disk" (== (+ no 1) (length (cdr o))))
(cons 'concat (cons `(with "point-style"
(if (< ll 2) ,(if sticky-point "square" "disk")
(if sticky-point ,(car h)) (cdr h))
'() h))
(if edge (cons
(list-head l 1) (list 'with "point-style" "disk"
(curp (list-head l 1)))) (cons 'concat
(if edge (if (< ll 2)
(with l2 (list-head l 2) (if sticky-point '()
(if sticky-point (if edge
`(,(cons* 'with (list-head l 1)
"point-style" (curp (list-head l 1))))
"square" (if edge
`((concat . (with l2 (list-head l 2)
,(cdr l2))))) (if sticky-point
l2)) `(with "point-style" "square"
(cons (concat ,@(cdr l2)))
`(with "point-style" l2))
"square" (cons
,(list-ref l 1)) `(with "point-style" "square"
(curp (list-head l 1))))))) '()) ,(list-ref l 1))
(if (> ll 2) (list-tail l 2) '()))) (curp (list-head l 1))))))) '())
(cdr o))))) (if (> ll 2) (list-tail l 2) '()))))
(else (cdr o))))
(define (compress l)
(cond ((or (null? l) (null? (cdr l))) l)
((null? (cddr l)) (cdr l))
(else (cons (car l) (compress (cddr l))))))
(define (compress* l)
(if (<= (length l) 50) l
(compress* (compress l))))
(define (create-graphical-contour o edge no)
(if (> (length o) 50)
(let* ((o2 (cons (car o) (compress (cdr o))))
(no2 (if (integer? no) (quotient no 2) no)))
(create-graphical-contour o2 edge no2))
(create-graphical-contour* o edge no)))
;; Graphical contours (group mode) ;; Graphical contours (group mode)
;;NOTE: This subsection is OK ;;NOTE: This subsection is OK
(define (add-selections-colors op color fill-color) (define (add-selections-colors op color fill-color)
(if (not color) (set! color "none")) (if (not color) (set! color "none"))
(if (not fill-color) (set! fill-color "none")) (if (not fill-color) (set! fill-color "none"))
`((with "color" ,color `((with "color" ,color
"point-style" "square" "point-style" "square"
"fill-color" ,fill-color "fill-color" ,fill-color
(concat . ,op)))) (concat ,@op))))
(define (create-graphical-contours l ptr pts) ;; Group mode (define (create-graphical-contours l ptr pts) ;; Group mode
;; This routine draws the contours of each one ;; This routine draws the contours of each one
;; of the trees contained in the list l. If the ;; of the trees contained in the list l. If the
;; path ptr is the path of one of the trees in ;; path ptr is the path of one of the trees in
;; the list, the corresponding object is drawn ;; the list, the corresponding object is drawn
;; using special points. Finally, the drawing ;; using special points. Finally, the drawing
;; is made according to the mode in pts (i.e., ;; is made according to the mode in pts (i.e.,
;; object, points, etc.). ;; object, points, etc.).
(define on-aobj #f) (define on-aobj #f)
(define aobj-selected #f) (define aobj-selected #f)
(define (asc col fcol op) (define (asc col fcol op)
(if (and on-aobj (not aobj-selected)) (if (and on-aobj (not aobj-selected))
(set! fcol #f)) (set! fcol #f))
(add-selections-colors op col fcol)) (add-selections-colors op col fcol))
(define res '()) (define res '())
(define curscol #f) (define curscol #f)
;;(display* "create-graphical-contours " l ", " ptr ", " pts "\n")
(for (o l) (for (o l)
(if (tree? o) (if (tree? o)
(with path (reverse (tree-ip o)) (with path (reverse (tree-ip o))
(if (== path ptr) (if (== path ptr)
(set! aobj-selected #t))))) (set! aobj-selected #t)))))
(if (and (== pts 'points) ptr) (if (and (== pts 'points) ptr)
(begin (begin
(set! l (cons (path->tree ptr) l)))) (set! l (cons (path->tree ptr) l))))
(set! l (append-map (lambda (x)
(or (graphics-anim-radicals x) (list x))) l))
(for (o l) (for (o l)
(if (not (and (tree? o) (< (cAr (tree-ip o)) 0))) (if (not (and (tree? o) (< (cAr (tree-ip o)) 0)))
(let* ((props #f) (let* ((props #f)
(t #f) (t #f)
(path0 #f)) (path0 #f))
(set! curscol #f) (set! curscol #f)
(set! on-aobj #f) (set! on-aobj #f)
(if (tree? o) (if (tree? o)
(with path (reverse (tree-ip o)) (with path (reverse (tree-ip o))
(set! props (create-graphical-props (if (== pts 'points) (set! props (create-graphical-props (if (== pts 'points)
'default path) 'default path)
(if (== pts 'object) (if (== pts 'object)
#f "square"))) #f "square")))
(if (== path ptr) (if (or (== path ptr)
(and (list? path) (list? ptr)
(list-starts? path ptr)))
(begin (begin
(set! on-aobj #t) (set! on-aobj #t)
(set! curscol default-color-go-points))) (set! curscol default-color-go-points)))
(set! path0 path) (set! path0 path)
(set! o (tree->stree o))) ;; FIXME: Remove this (tree->stree) (set! o (tree->stree o))) ;; FIXME: Remove this (tree->stree)
) )
(if (and (== (car o) 'gr-group) (!= pts 'object)) (if (and (== (car o) 'gr-group) (!= pts 'object))
(set! props (create-graphical-props 'default #f))) (set! props (create-graphical-props 'default #f)))
(cond ((== (car o) 'point) (cond ((== (car o) 'point)
(if (not curscol) (if (not curscol)
(set! curscol default-color-selected-points)) (set! curscol default-color-selected-points))
(set! t (if (== pts 'object) (set! t (if (== pts 'object)
`(,o) `(,o)
(asc curscol #f `(,o))))) (asc curscol #f `(,o)))))
((graphical-text-at-context? o) ((graphical-text-at-context? o)
(if (not curscol) (if (not curscol)
(set! curscol default-color-selected-points)) (set! curscol default-color-selected-points))
(set! t (set! t
(let* ((ha (get-graphical-prop path0 "text-at-halign")) (let* ((valign-var (graphics-valign-var o))
(va (get-graphical-prop path0 "text-at-valign")) (ha (get-graphical-prop path0 "text-at-halign"))
(va (get-graphical-prop path0 valign-var))
(w (get-graphical-prop path0 "doc-at-width"))
(hm (get-graphical-prop path0 "doc-at-hmode"))
(pp (get-graphical-prop path0 "doc-at-ppsep"))
(mag (get-graphical-prop path0 "magnify")) (mag (get-graphical-prop path0 "magnify"))
(gc (asc curscol #f (gc (asc curscol #f
(create-graphical-embedding-box (create-graphical-embedding-box
o ha va ha va mag)))) o ha va ha va w hm pp mag))))
(if (== pts 'object-and-points) (if (== pts 'object-and-points)
(cons o gc) (cons o gc)
(if (== pts 'object) (if (== pts 'object)
`(,o) `(,o)
gc))))) gc)))))
((== (car o) 'gr-group) ((== (car o) 'gr-group)
(if (not curscol) (if (not curscol)
(set! curscol default-color-selected-points)) (set! curscol default-color-selected-points))
(set! t (with gc (asc curscol #f (set! t (with gc (asc curscol #f
(let* ((ha (get-graphical-prop (let* ((ha (get-graphical-prop
path0 "text-at-halign")) path0 "text-at-halign"))
(va (get-graphical-prop (va (get-graphical-prop
path0 "text-at-valign")) path0 "text-at-valign"))
(mag (get-graphical-prop (mag (get-graphical-prop
path0 "magnify"))) path0 "magnify")))
(create-graphical-embedding-box (create-graphical-embedding-box
o ha va "center" "center" mag))) o ha va "center" "center"
"1par" "min" "0fn" mag)))
(if (== pts 'object-and-points) (if (== pts 'object-and-points)
(cons o gc) (cons o gc)
(if (== pts 'object) (if (== pts 'object)
`(,o) `(,o)
gc))))) gc)))))
(else (else
(set! t (if (== pts 'object-and-points) (set! t (if (== pts 'object-and-points)
(cons o (cons o
(asc curscol default-color-selected-points (asc curscol default-color-selected-points
(cdr o))) (compress* (cdr o))))
(if (== pts 'object) (if (== pts 'object)
`(,o) `(,o)
(asc curscol default-color-selected-points (asc curscol default-color-selected-points
(cdr o))))))) (compress* (cdr o))))))))
(set! res (append res (set! res (append res
(if props (if props
`(,(append props `(,(cons* 'concat t)))) `(,(append props `(,(cons* 'concat t))))
t)))))) t))))))
res) res)
;; Create graphical object ;; Create graphical object
;;NOTE: This subsection is OK ;;NOTE: This subsection is OK
(define (get-local-magnify) (define (get-local-magnify)
skipping to change at line 437 skipping to change at line 472
(let* ((op (add-selections-colors (let* ((op (add-selections-colors
(create-graphical-contour o edge no) (create-graphical-contour o edge no)
default-color-go-points #f)) default-color-go-points #f))
(props (if (and pts (!= pts 'points)) (props (if (and pts (!= pts 'points))
(create-graphical-props mode #f) (create-graphical-props mode #f)
(create-graphical-props 'default #f))) (create-graphical-props 'default #f)))
(mag-o `(with "magnify" ,(get-local-magnify) ,o))) (mag-o `(with "magnify" ,(get-local-magnify) ,o)))
;;(display* "-------\n") ;;(display* "-------\n")
;;(display* "o= " o ", mode= " mode ", pts= " pts ", op= " op "\n") ;;(display* "o= " o ", mode= " mode ", pts= " pts ", op= " op "\n")
;;(display* "no= " no ", props= " props "\n") ;;(display* "no= " no ", props= " props "\n")
(when (== (car (graphics-mode)) 'hand-edit)
(set! op (list `(concat))))
(graphical-object! (graphical-object!
(if (or (== no 'group) (if (or (== no 'group)
(and (!= no 'no-group) (and (!= no 'no-group)
(graphics-group-mode? (graphics-mode)))) (graphics-group-mode? (graphics-mode))))
`(with "magnify" ,(number->string `(with "magnify" ,(number->string
(magnify->number (magnify->number
(graphics-get-property "magnify"))) (graphics-get-property "magnify")))
(concat ,@(create-graphical-contours (concat ,@(create-graphical-contours
(map (lambda (x) (map (lambda (x)
(if (tree? x) (if (tree? x)
skipping to change at line 492 skipping to change at line 529
(== 1 (length (sketch-get)))) (== 1 (length (sketch-get))))
(set! current-obj (car (sketch-get)))) (set! current-obj (car (sketch-get))))
(if (tree? current-obj) (if (tree? current-obj)
(set! current-obj (tree->stree current-obj))) (set! current-obj (tree->stree current-obj)))
(if (and (== mode 'active) (if (and (== mode 'active)
(pair? current-obj)) (pair? current-obj))
(begin (begin
(graphical-fetch-props (graphical-fetch-props
(if (== (car current-obj) 'with) (if (== (car current-obj) 'with)
current-obj `(with ,current-obj))) current-obj `(with ,current-obj)))
(set! current-obj (stree-radical current-obj)))) (set! current-obj (stree-radical* current-obj #f))))
(create-graphical-object (create-graphical-object
current-obj current-obj
mode mode
(if sticky-point 'object-and-points 'points) (if sticky-point 'object-and-points 'points)
(if (graphical-text-tag? tag) (if (graphical-text-tag? tag)
1 1
(cond ((or (not tag) (cond ((or (not tag)
(== tag 'gr-group)) (== tag 'gr-group))
#f) #f)
(else (else
 End of changes. 22 change blocks. 
57 lines changed or deleted 94 lines changed or added

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