[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Texmacs-edu] Développement du mode graphique
|
From: |
Joris van der Hoeven |
|
Subject: |
Re: [Texmacs-edu] Développement du mode graphique |
|
Date: |
Fri, 6 Jul 2012 23:13:45 +0200 |
|
User-agent: |
Mutt/1.5.20 (2009-06-14) |
Juste pour confirmer que je recois bien le message sur texmacs-edu. Amities,
--Joris
On Fri, Jul 06, 2012 at 01:57:59AM +0200, address@hidden wrote:
> Bonsoir à tous,
>
> Grâce à un travail préparatoire de Joris, j'ai apporté quelques
> "améliorations" au mode graphique de TeXmacs.
> Vous pouvez facilement essayer ces modifications avec les dernières sources
> en
> copiant graphics-markup.scm et graphics-menu.scm dans le dossier
> TeXmacs/progs/graphics
> et en copiant graphical-macros.ts dans TeXmacs/packages/customize
>
> Il faut ensuite ajouter le package Customize->graphical-macros puis lancer le
> mode graphique.
>
> Les commandes sont accessibles à partir de Insérer->Constructions...
> Codages->
> Angle droit ABC (à venir les codages des angles et segments)
> Points->
> Milieu de AB
> Centre de gravité de ABC (à venir les différents points particuliers)
> Droites->
> Perpendiculaire à AB passant par C
> Parallèle à AB passant par C
> Médiatrice de AB
> Bissectrice de ABC (à venir les vecteurs...)
> Cercles->
> Cercle de centre C passant par A
> Cercle de diamètre AB (à venir les cercles particuliers dans le
> triangle)
> Triangles->
> Triangle ABC équilatéral
> Triangle ABC isocèle en B
> Triangle ABC isocèle en C
> Triangle ABC rectangle en B
> Triangle ABC rectangle en C
> Quadrilatères->
> Carré ABCD
> Rectangle horizontal ABCD de diagonale AC
> Rectangle ABCD connaissant A B C (à venir les parallélogrammes)
> Polygones réguliers-> (à venir les polygones réguliers à n côtés, étoilés
> ou non)
>
> Les menus sont un peu longs mais assez parlants. L'ordre des points à son
> importance, voir par exemple la différence entre :
> Triangle ABC isocèle en B et Triangle ABC isocèle en C
> Par exemple pour tracer une perpendiculaire à (AB) passant par C, il suffit
> de sélectionner dans l'ordre A B C puis deux points pour définir la longueur
> de la "droite" (AB). Tous les points sont repositionnables.
> Le résultat est assez bluffant. D'après Joris, il n'est pas encore possible
> d'insérer des figures contenant un texte modifiable.
>
> Voir aussi le menu Electronic fait par Joris, qu'il sera très facile de
> compléter (peut-être à partir d'un document de référence assez exhaustif sur
> le sujet).
>
> Il ne s'agit que d'un début. Je vais continuer dans cette voie après avoir
> écouté vos remarques. Mon objectif premier serait de permettre toutes les
> constructions types de GeoGebra en m'appuyant un peu sur l'esprit Eukleides
> (voir par exemple les différents triangles).
> Je me suis déjà un peu amusé et les constructions sont vraiment très rapides
> et efficaces
>
> Merci Joris pour ce très bel outil.
> Cordialement.
>
> Emmanuël
>
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;;
> ;; MODULE : graphics-markup.scm
> ;; DESCRIPTION : extra graphical macros
> ;; COPYRIGHT : (C) 2012 Joris van der Hoeven
> ;;
> ;; 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
> ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
> ;;
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (texmacs-module (graphics graphics-markup)
> (:use (graphics graphics-drd)))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Definition of graphical macros
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (define (ca*r x) (if (pair? x) (ca*r (car x)) x))
>
> (tm-define-macro (define-graphics head . l)
> (receive (opts body) (list-break l not-define-option?)
> `(begin
> (set! gr-tags-user (cons ',(ca*r head) gr-tags-user))
> (tm-define ,head ,@opts (:secure #t) ,@body))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Useful subroutines
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (tm-define (tm-point? p) (tm-func? p 'point 2))
> (tm-define (tm-x p) (tm-ref p 0))
> (tm-define (tm-y p) (tm-ref p 1))
>
> (tm-define (tm->number t)
> (if (tm-atomic? t) (string->number (tm->string t)) 0))
>
> (tm-define (number->tm x)
> (number->string x))
>
> (tm-define (point->complex p)
> (make-rectangular (tm->number (tm-x p)) (tm->number (tm-y p))))
>
> (tm-define (complex->point z)
> `(point ,(number->tm (real-part z)) ,(number->tm (imag-part z))))
>
> (tm-define (graphics-transform fun g)
> (cond ((tm-point? g) (fun g))
> ((tm-atomic? g) g)
> (else (cons (tm-car g)
> (map (cut graphics-transform fun <>)
> (tm-children g))))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> ;; fig-division for complexe numbers
> (tm-define (fig-/ z1 z2)
> (let* ((a (real-part z1))
> (b (imag-part z1))
> (c (real-part z2))
> (d (imag-part z2))
> (e (/ (+ (* a c) (* b d)) (+ (* c c) (* d d))))
> (f (/ (- (* b c) (* a d)) (+ (* c c) (* d d)))))
> (make-rectangular e f)
> ))
>
> ;; "middle" of 2 numbers
> (tm-define (fig-middle z1 z2)
> (fig-/ (+ z1 z2) 2))
>
> ;; define pi
> (tm-define (pi) (acos -1))
>
> ;; transform an angle from degrees to radians
> (tm-define (fig-deg->rad a)
> (/ (* (pi) a) 180))
>
> ;; transform an angle in [-pi;pi[ to an angle in [0;2pi[ (use with angle)
> (tm-define (fig-posangle a)
> (if (< a 0)
> (+ a (* 2 (pi)))
> a))
>
> ;; give the rotation of z1 (center z and angle a)
> (tm-define (fig-rotation z1 z a)
> (+ z (* (- z1 z) (make-polar 1 a))))
>
> ;; give the complex intersection of two lines of equations a1x+b1y=c1 '(a1 b1
> c1) and a2x+b2y=c2 '(a2 b2 c2)
> (tm-define (fig-inter-lines-list ls1 ls2)
> (let* ((a1 (list-ref ls1 0))
> (b1 (list-ref ls1 1))
> (c1 (list-ref ls1 2))
> (a2 (list-ref ls2 0))
> (b2 (list-ref ls2 1))
> (c2 (list-ref ls2 2))
> (x (/ (- (* b2 c1) (* b1 c2)) (- (* a1 b2) (* a2 b1))))
> (y (/ (- (* a1 c2) (* a2 c1)) (- (* a1 b2) (* a2 b1)))))
> (if (!= 0 (- (* a1 b2) (* a2 b1)))
> (make-rectangular x y))))
>
> ;; give the list of coeff '(a b c) of the equation of line (AB) (ax+by=c)
> knowing zA and zB
> (tm-define (fig-equation-line z1 z2)
> (let ((x1 (real-part z1))
> (y1 (imag-part z1))
> (x2 (real-part z2))
> (y2 (imag-part z2)))
> (if (!= z1 z2)
> `(,(- y2 y1) ,(- x1 x2) ,(- (* x1 y2) (* x2 y1))))))
>
> ;; give the complex intersection of 2 lines (a b) and (c d)
> (tm-define (fig-inter-lines a b c d)
> (fig-inter-lines-list (fig-equation-line a b) (fig-equation-line c d)))
>
> ;; give the complex intersection (with positive imaginary part) of the circle
> of center 0 and radius r1
> ;; and of the circle of center a and radius r2 ;;;; adapt for other cases
> (tm-define (fig-inter-circles ls-circ1 ls-circ2)
> (let* ((z1 (list-ref ls-circ1 0))
> (r1 (list-ref ls-circ1 1))
> (z2 (list-ref ls-circ2 0))
> (r2 (list-ref ls-circ2 1))
> (x (+ (fig-/ z2 2) (fig-/ (- (* r1 r1) (* r2 r2)) (* 2 z2))))
> (y (sqrt (- (* r1 r1) (* x x)))))
> (make-rectangular x y)
> ))
>
> ;; give a complex point (at length len of z2) on the bisector of an angle
> defined by z1 z2 z3
> (tm-define (fig-point-on-bisector z1 z2 z3 len)
> (+ z2 (* len (fig-unit (- (fig-rotation z1 z2 (fig-/ (fig-posangle (angle
> (fig-/ (- z3 z2) (- z1 z2)))) 2)) z2)))))
>
> ;; give the projection of z on line (ab) perpendicularly to line (ab)
> (tm-define (fig-projection z a b)
> (let* ((c (+ z (fig-normal (- a b)))))
> (fig-inter-lines a b c z)))
>
> ;; give the reflection of z in respect of line '(a b)
> (tm-define (fig-line-reflection z ls-pts)
> (let* ((m (fig-projection z ls-pts)))
> (+ z (* 2 (- m z)))))
>
> ;; give a complex point (at length len of z2) on the bisector of an angle
> defined by z1 z2 z3
> (tm-define (fig-point-on-bisector z1 z2 z3 len)
> (+ z2 (* len (fig-unit (- (fig-rotation z1 z2 (fig-/ (fig-posangle (angle
> (fig-/ (- z3 z2) (- z1 z2)))) 2)) z2)))))
>
> ;; unit vector of z
> (tm-define (fig-unit z)
> (fig-/ z (magnitude z)))
>
> ;; normal vector of z
> (tm-define (fig-normal z)
> (fig-unit (* z (make-polar 1 (/ (pi) 2)))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Encodings
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (define-graphics (rightangle p1 p2 p3)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (if (tm-point? p3) (point->complex p3) z2))
> (dz (- z1 z2))
> (l (magnitude dz))
> (d1 (if (= dz 0) 0 (* l (imag-part (/ (- z3 z1) dz)))))
> (z4 (+ z2 (* (/ d1 2) dz)))
> (z5 (fig-rotation z2 z4 (* 3 (/ (pi) 2))))
> (z6 (fig-rotation z4 z2 (/ (pi) 2))))
> `(superpose
> (line ,(complex->point z4) ,(complex->point z5) ,(complex->point z6))
> (with "point-style" "none" ,p3))))
>
> (define-graphics (angle1 p1 p2 p3)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (if (tm-point? p3) (point->complex p3) z2))
> (dza (- z3 z2))
> (dzb (- z1 z2))
> (l (/ (magnitude dzb) (magnitude dza)))
> (t (if (= dzb 0) 0 (* l (imag-part (/ (- z3 z1) dz)))))
> (z4 (+ z2 (* (/ d1 2) dz)))
> (z5 (fig-rotation z2 z4 (* 3 (/ (pi) 2))))
> (z6 (fig-rotation z4 z2 (/ (pi) 2))))
> `(superpose
> (cline ,(complex->point z2) ,(complex->point z4)
> ,(complex->point z5) ,(complex->point z6))
> (with "point-style" "none" ,p3))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Points
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (define-graphics (middle p1 p2)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (fig-/ (+ z1 z2) 2)))
> `(superpose
> (with "point-style" "none" ,p1)
> (with "point-style" "none" ,p2)
> ,(complex->point z3)))) ;; FIXME : problem to change
> the style of this point
>
> (define-graphics (gravity p1 p2 p3)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (if (tm-point? p3) (point->complex p3) z2))
> (zm (fig-middle z1 z2) )
> (zg (+ zm (/ (- z3 zm) 3))))
> `(superpose
> (with "point-style" "none" ,p1)
> (with "point-style" "none" ,p2)
> (with "point-style" "none" ,p3)
> ,(complex->point zg)))) ;; FIXME : problem to change
> the style of this point
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Lines
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (tm-define (gen-perpendicular p1 p2 p3 p4 p5)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (if (tm-point? p3) (point->complex p3) z2))
> (z4 (if (tm-point? p4) (point->complex p4) z3))
> (z5 (if (tm-point? p5) (point->complex p5) z4))
> (dz (- z2 z1))
> (l (magnitude dz))
> (d1 (if (= dz 0) 0 (* l (imag-part (fig-/ (- z4 z3) dz)))))
> (d2 (if (= dz 0) 0 (* l (imag-part (fig-/ (- z5 z3) dz)))))
> (z6 (+ z3 (* d1 (fig-normal dz))))
> (z7 (+ z3 (* d2 (fig-normal dz)))))
> `(superpose
> (with "point-style" "none" ,p1)
> (with "point-style" "none" ,p2)
> (with "point-style" "none" ,p3)
> (with "point-style" "none" ,p4)
> (with "point-style" "none" ,p5)
> (line ,(complex->point z6) ,(complex->point z7)))))
>
> (define-graphics (perpendicular p1 p2 p3 p4 p5)
> (gen-perpendicular p1 p2 p3 p4 p5))
>
> (define-graphics (mediator p1 p2 p4 p5)
> (gen-perpendicular p1 p2 (complex->point (fig-middle (point->complex p1)
> (point->complex p2))) p4 p5))
>
> (define-graphics (parallel p1 p2 p3 p4 p5)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (if (tm-point? p3) (point->complex p3) z2))
> (z4 (if (tm-point? p4) (point->complex p4) z3))
> (z5 (if (tm-point? p5) (point->complex p5) z4))
> (dz (- z2 z1))
> (l (magnitude dz))
> (d1 (if (= dz 0) 0 (* l (real-part (fig-/ (- z4 z3) dz)))))
> (d2 (if (= dz 0) 0 (* l (real-part (fig-/ (- z5 z3) dz)))))
> (z6 (+ z3 (* d1 (fig-unit dz))))
> (z7 (+ z3 (* d2 (fig-unit dz)))))
> `(superpose
> (with "point-style" "none" ,p1)
> (with "point-style" "none" ,p2)
> (with "point-style" "none" ,p3)
> (with "point-style" "none" ,p4)
> (with "point-style" "none" ,p5)
> (line ,(complex->point z6) ,(complex->point z7)))))
>
> (define-graphics (bisector p1 p2 p3 p4 p5)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (if (tm-point? p3) (point->complex p3) z2))
> (z4 (if (tm-point? p4) (point->complex p4) z3))
> (z5 (if (tm-point? p5) (point->complex p5) z4))
> (z6 (if (= z2 (fig-middle z1 z3)) (+ z2 (fig-normal (- z1 z2)))
> (fig-middle z1 z3)))
> (dz (- z6 z2))
> (l (magnitude dz))
> (d7 (if (= dz 0) 0 (* l (real-part (fig-/ (- z4 z2) dz)))))
> (d8 (if (= dz 0) 0 (* l (real-part (fig-/ (- z5 z2) dz)))))
> (z7 (+ z2 (* d7 (fig-unit dz))))
> (z8 (+ z2 (* d8 (fig-unit dz)))))
> `(superpose
> (with "point-style" "none" ,p1) (with "point-style" "none" ,p2)
> (with "point-style" "none" ,p3) (with "point-style" "none" ,p4)
> (with "point-style" "none" ,p5)
> (line ,(complex->point z7) ,(complex->point z8)))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Triangles
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (define-graphics (equilateral P1 P2)
> (let* ((z1 (if (tm-point? P1) (point->complex P1) 0))
> (z2 (if (tm-point? P2) (point->complex P2) z1))
> (z3 (fig-rotation z1 z2 (* 5 (/ (pi) 3)))))
> `(cline ,(complex->point z1) ,(complex->point z2) ,(complex->point z3))))
>
> (define-graphics (isosceles p1 p2 p3)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (if (tm-point? p3) (point->complex p3) z2))
> (dz (- z2 z1))
> (l (magnitude dz))
> (d1 (if (= dz 0) 0 (* l (imag-part (/ (- z3 z1) dz)))))
> (vm (/ (+ z1 z2) 2))
> (z4 (+ vm (* d1 (fig-normal dz)))))
> `(superpose
> (cline ,(complex->point z1) ,(complex->point z2) ,(complex->point z4))
> (with "point-style" "none" ,p3))))
>
> (define-graphics (isosceles2 p1 p2 p3)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (if (tm-point? p3) (point->complex p3) z2))
> (dz (- z2 z1))
> (l (magnitude dz))
> (z4 (+ z2 (* l (fig-unit (- z3 z2))))))
> `(superpose
> (cline ,(complex->point z1) ,(complex->point z2) ,(complex->point z4))
> (with "point-style" "none" ,p3))))
>
> (define-graphics (right-angled-triangle p1 p2 p3)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (if (tm-point? p3) (point->complex p3) z2))
> (dz (- z2 z1))
> (l (magnitude dz))
> (d1 (if (= dz 0) 0 (* l (imag-part (/ (- z3 z1) dz)))))
> (z4 (+ z2 (* d1 (fig-normal dz)))))
> `(superpose
> (cline ,(complex->point z1) ,(complex->point z2) ,(complex->point z4))
> (with "point-style" "none" ,p3))))
>
> (define-graphics (right-angled-triangle2 p1 p2 p3)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (if (tm-point? p3) (point->complex p3) z2))
> (z4 (fig-projection z1 z2 z3)))
> `(superpose
> (cline ,(complex->point z1) ,(complex->point z2) ,(complex->point z4))
> (with "point-style" "none" ,p3))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Quadrilaterals
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (define-graphics (square P1 P2)
> (let* ((z1 (if (tm-point? P1) (point->complex P1) 0))
> (z2 (if (tm-point? P2) (point->complex P2) z1))
> (z3 (fig-rotation z1 z2 (* 3 (/ (pi) 2))))
> (z4 (fig-rotation z2 z1 (/ (pi) 2))))
> `(cline ,(complex->point z1) ,(complex->point z2)
> ,(complex->point z3) ,(complex->point z4))))
>
> (define-graphics (rectangle P1 P2)
> (let* ((p1 (if (tm-point? P1) P1 '(point "0" "0")))
> (p2 (if (tm-point? P2) P2 p1)))
> `(cline ,p1 (point ,(tm-x p2) ,(tm-y p1))
> ,p2 (point ,(tm-x p1) ,(tm-y p2)))))
>
> (define-graphics (rectangle2 p1 p2 p3)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (if (tm-point? p3) (point->complex p3) z2))
> (dz (- z2 z1))
> (l (magnitude dz))
> (d1 (if (= dz 0) 0 (* l (imag-part (/ (- z3 z1) dz)))))
> (z4 (+ z2 (* d1 (fig-normal dz))))
> (z5 (+ z1 (* d1 (fig-normal dz)))))
> `(superpose
> (cline ,(complex->point z1) ,(complex->point z2)
> ,(complex->point z4) ,(complex->point z5))
> (with "point-style" "none" ,p3))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Circles
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (define-graphics (circle C P)
> (let* ((c (if (tm-point? C) C '(point "0" "0")))
> (p (if (tm-point? P) P c))
> (cx (tm-x c)) (cy (tm-y c))
> (px (tm-x p)) (py (tm-y p))
> (dx `(minus ,px ,cx)) (dy `(minus ,py ,cy))
> (q1 `(point (minus ,cx ,dx) (minus ,cy ,dy)))
> (q2 `(point (minus ,cx ,dy) (plus ,cy ,dx))))
> `(superpose (with "point-style" "none" ,c) (carc ,p ,q1 ,q2))))
>
> (define-graphics (circle2 P1 P2)
> (let* ((z1 (if (tm-point? P1) (point->complex P1) 0))
> (z2 (if (tm-point? P2) (point->complex P2) z1))
> (z3 (fig-rotation z1 (fig-middle z1 z2) (/ (pi) 2))))
> `(carc ,(complex->point z1) ,(complex->point z3) ,(complex->point z2))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Polygons
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (define-graphics (pentagon P1 P2)
> (let* ((z1 (if (tm-point? P1) (point->complex P1) 0))
> (z2 (if (tm-point? P2) (point->complex P2) z1))
> (z3 (fig-rotation z1 z2 (* 7 (/ (pi) 5))))
> (z4 (fig-rotation z2 z3 (* 7 (/ (pi) 5))))
> (z5 (fig-rotation z3 z4 (* 7 (/ (pi) 5)))))
> `(cline ,(complex->point z1) ,(complex->point z2)
> ,(complex->point z3) ,(complex->point z4) ,(complex->point z5))))
>
> (define-graphics (hexagon P1 P2)
> (let* ((z1 (if (tm-point? P1) (point->complex P1) 0))
> (z2 (if (tm-point? P2) (point->complex P2) z1))
> (z3 (fig-rotation z1 z2 (* 4 (/ (pi) 3))))
> (z4 (fig-rotation z2 z3 (* 4 (/ (pi) 3))))
> (z5 (fig-rotation z3 z4 (* 4 (/ (pi) 3))))
> (z6 (fig-rotation z4 z5 (* 4 (/ (pi) 3)))))
> `(cline ,(complex->point z1) ,(complex->point z2)
> ,(complex->point z3) ,(complex->point z4)
> ,(complex->point z5) ,(complex->point z6))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Other figures
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Electrical diagrams
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (define ((rescale z0 dz) p)
> (complex->point (+ z0 (* dz (point->complex p)))))
>
> (tm-define (electrical im scale p1 p2 p3)
> (let* ((z1 (if (tm-point? p1) (point->complex p1) 0))
> (z2 (if (tm-point? p2) (point->complex p2) z1))
> (z3 (if (tm-point? p3) (point->complex p3) z2))
> (dz (- z2 z1))
> (l (magnitude dz))
> (d1 (if (= dz 0) 0 (abs (* l (imag-part (/ (- z3 z1) dz))))))
> (d2 (/ (min l (/ d1 scale)) 2))
> (u (if (= dz 0) 0 (* d2 (/ dz l))))
> (vm (/ (+ z1 z2) 2))
> (v1 (- vm u))
> (v2 (+ vm u))
> (rescaler (rescale v1 (- v2 v1))))
> `(superpose
> (line ,p1 ,(complex->point v1))
> ,(graphics-transform rescaler im)
> (line ,(complex->point v2) ,p2)
> (with "point-style" "none" ,p3))))
>
> (define (std-condensator)
> `(superpose
> (line (point "0" "-2") (point "0" "2"))
> (line (point "1" "-2") (point "1" "2"))))
>
> (define-graphics (condensator p1 p2 p3)
> (electrical (std-condensator) 2 p1 p2 p3))
>
> (define (std-diode)
> `(superpose
> (cline (point "0" "-0.5") (point "1" "0") (point "0" "0.5"))
> (line (point "1" "-0.5") (point "1" "0.5"))))
>
> (define-graphics (diode p1 p2 p3)
> (electrical (std-diode) 0.5 p1 p2 p3))
>
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;;
> ;; MODULE : graphics-menu.scm
> ;; DESCRIPTION : menus for graphics mode
> ;; COPYRIGHT : (C) 1999 Joris van der Hoeven
> ;;
> ;; 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
> ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
> ;;
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (texmacs-module (graphics graphics-menu)
> (:use (graphics graphics-env)
> (graphics graphics-main)
> (graphics graphics-edit)
> (graphics graphics-markup)))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Submenus
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> ;; FIXME: provide automatic checkmarks for these actions
>
> (menu-bind graphics-extents-menu
> ("Width" (interactive graphics-set-width))
> ("Height" (interactive graphics-set-height)))
>
> (menu-bind graphics-auto-crop-menu
> ("Crop" (graphics-toggle-auto-crop))
> ---
> (when (graphics-auto-crop?)
> (group "Padding")
> ("none" (graphics-set-crop-padding "0spc"))
> ("1 spc" (graphics-set-crop-padding "1spc"))
> ("1 em" (graphics-set-crop-padding "1em"))
> ---
> ("Other" (interactive graphics-set-crop-padding))))
>
> (menu-bind graphics-alignment-menu
> ("Top" (graphics-set-geo-valign "top"))
> ("Axis" (graphics-set-geo-valign "axis"))
> ("Center" (graphics-set-geo-valign "center"))
> ("Bottom" (graphics-set-geo-valign "bottom")))
>
> (menu-bind graphics-resize-menu
> (group "Width")
> ("Fast decrease" (graphics-decrease-hsize-fast))
> ("Slow decrease" (graphics-decrease-hsize))
> ("Slow increase" (graphics-increase-hsize))
> ("Fast increase" (graphics-increase-hsize-fast))
> ---
> (group "Height")
> ("Fast decrease" (graphics-decrease-vsize-fast))
> ("Slow decrease" (graphics-decrease-vsize))
> ("Slow increase" (graphics-increase-vsize))
> ("Fast increase" (graphics-increase-vsize-fast)))
>
> (menu-bind graphics-frame-unit-menu
> ("1 cm" (graphics-set-unit "1cm"))
> ("1 inch" (graphics-set-unit "1in"))
> ;;("5 em" (graphics-set-unit "5em"))
> ---
> ("Other" (interactive graphics-set-unit)))
>
> (menu-bind graphics-frame-origin-menu
> ("Center" (graphics-set-origin "0.5gw" "0.5gh"))
> ("Left top" (graphics-set-origin "0gw" "1gh"))
> ("Left axis" (graphics-set-origin "0gw" (length-add "0.5gh" "1yfrac")))
> ("Left center" (graphics-set-origin "0gw" "0.5gh"))
> ("Left bottom" (graphics-set-origin "0gw" "0gh"))
> ---
> ("Other" (interactive graphics-set-origin)))
>
> (menu-bind graphics-move-menu
> (group "Slow")
> ("Left" (graphics-move-origin-left))
> ("Right" (graphics-move-origin-right))
> ("Down" (graphics-move-origin-down))
> ("Up" (graphics-move-origin-up))
> ---
> (group "Fast")
> ("Left" (graphics-move-origin-left-fast))
> ("Right" (graphics-move-origin-right-fast))
> ("Down" (graphics-move-origin-down-fast))
> ("Up" (graphics-move-origin-up-fast)))
>
> (menu-bind graphics-zoom-menu
> ("Zoom in" (graphics-zoom-in))
> ("Zoom out" (graphics-zoom-out))
> ---
> ("10%" (graphics-set-zoom 0.1))
> ("25%" (graphics-set-zoom 0.25))
> ("50%" (graphics-set-zoom 0.5))
> ("75%" (graphics-set-zoom 0.75))
> ("100%" (graphics-set-zoom 1.0))
> ("150%" (graphics-set-zoom 1.5))
> ("200%" (graphics-set-zoom 2.0))
> ("300%" (graphics-set-zoom 3.0))
> ("400%" (graphics-set-zoom 4.0))
> ("500%" (graphics-set-zoom 5.0))
> ("1000%" (graphics-set-zoom 10.0)))
>
> (menu-bind graphics-global-menu
> (group "Graphics")
> (-> "Size" (link graphics-extents-menu))
> (-> "Resize" (link graphics-resize-menu))
> (-> "Crop" (link graphics-auto-crop-menu))
> (-> "Alignment" (link graphics-alignment-menu))
> ---
> (-> "Unit" (link graphics-frame-unit-menu))
> (-> "Origin" (link graphics-frame-origin-menu))
> (-> "Move" (link graphics-move-menu))
> (-> "Zoom" (link graphics-zoom-menu)))
>
> (menu-bind graphics-visual-grid-menu
> (-> "Type"
> ("No grid" (graphics-set-visual-grid 'empty))
> ---
> ("Cartesian" (graphics-set-visual-grid 'cartesian))
> ("Polar" (graphics-set-visual-grid 'polar))
> ("Logarithmic" (graphics-set-visual-grid 'logarithmic)))
> (when (!= (graphics-get-grid-type #t) 'empty)
> (-> "Center"
> ("Default" (graphics-set-grid-center "0" "0" #t))
> ---
> ("Other" (graphics-interactive-set-grid-center #t)))
> (-> "Unit length"
> ("Default" (graphics-set-grid-step "1" #t))
> ---
> ("0.1" (graphics-set-grid-step "0.1" #t))
> ("0.2" (graphics-set-grid-step "0.2" #t))
> ("0.5" (graphics-set-grid-step "0.5" #t))
> ("1" (graphics-set-grid-step "1" #t))
> ("2" (graphics-set-grid-step "2" #t))
> ("5" (graphics-set-grid-step "5" #t))
> ("10" (graphics-set-grid-step "10" #t))
> ---
> ("Other" (graphics-interactive-set-grid-step #t))))
> (when (== (graphics-get-grid-type #t) 'polar)
> (-> "Number of polar steps"
> ("Default" (graphics-set-grid-astep "24" #t))
> ---
> ("4" (graphics-set-grid-astep "4" #t))
> ("6" (graphics-set-grid-astep "6" #t))
> ("8" (graphics-set-grid-astep "8" #t))
> ("12" (graphics-set-grid-astep "12" #t))
> ("16" (graphics-set-grid-astep "16" #t))
> ("24" (graphics-set-grid-astep "24" #t))
> ("30" (graphics-set-grid-astep "30" #t))
> ("36" (graphics-set-grid-astep "36" #t))
> ---
> ("Other" (graphics-interactive-set-grid-astep #t))))
> (when (== (graphics-get-grid-type #t) 'logarithmic)
> (-> "Logarithmic base"
> ("Default" (graphics-set-grid-base "10" #t))
> ---
> ("6" (graphics-set-grid-base "6" #t))
> ("8" (graphics-set-grid-base "8" #t))
> ("10" (graphics-set-grid-base "10" #t))
> ("16" (graphics-set-grid-base "16" #t))
> ---
> ("Other" (graphics-interactive-set-grid-base #t))))
> ---
> (group "Aspect")
> (when (!= (graphics-get-grid-type #t) 'empty)
> (-> "Color of the axes" (link grid-color-axes-menu))
> (-> "Color of the units" (link grid-color-units-menu))
> ("Show subunits" (grid-toggle-show-subunits))
> (when (grid-show-subunits?)
> (-> "Color of the subunits" (link grid-color-subunits-menu))
> (when (or (== (graphics-get-grid-type #t) 'cartesian)
> (== (graphics-get-grid-type #t) 'polar))
> (-> "Number of subunit steps"
> ("Default" (graphics-set-grid-aspect 'detailed #f #t))
> ---
> ("2" (graphics-set-grid-aspect 'detailed 2 #t))
> ("3" (graphics-set-grid-aspect 'detailed 3 #t))
> ("4" (graphics-set-grid-aspect 'detailed 4 #t))
> ("5" (graphics-set-grid-aspect 'detailed 5 #t))
> ("6" (graphics-set-grid-aspect 'detailed 6 #t))
> ("8" (graphics-set-grid-aspect 'detailed 8 #t))
> ("10" (graphics-set-grid-aspect 'detailed 10 #t))
> ---
> ("Other" (graphics-interactive-set-grid-nsubds #t)))))))
>
> (menu-bind graphics-edit-grid-menu
> ("As visual grid" (grid-toggle-as-visual-grid))
> ---
> (-> "Type"
> ("No grid" (graphics-set-edit-grid 'empty))
> ---
> ("Cartesian" (graphics-set-edit-grid 'cartesian))
> ("Polar" (graphics-set-edit-grid 'polar))
> ("Logarithmic" (graphics-set-edit-grid 'logarithmic)))
> (when (!= (graphics-get-grid-type #f) 'empty)
> (-> "Center"
> ("Default" (graphics-set-grid-center "0" "0" #f))
> ---
> ("Other" (graphics-interactive-set-grid-center #f)))
> (-> "Unit length"
> ("Default" (graphics-set-grid-step "0.1" #f))
> ---
> ("0.05" (graphics-set-grid-step "0.05" #f))
> ("0.1" (graphics-set-grid-step "0.1" #f))
> ("0.2" (graphics-set-grid-step "0.2" #f))
> ("0.5" (graphics-set-grid-step "0.5" #f))
> ("1" (graphics-set-grid-step "1" #f))
> ("2" (graphics-set-grid-step "2" #f))
> ("5" (graphics-set-grid-step "5" #f))
> ("10" (graphics-set-grid-step "10" #f))
> ---
> ("Other" (graphics-interactive-set-grid-step #f))))
> (when (== (graphics-get-grid-type #f) 'polar)
> (-> "Number of polar steps"
> ("Default" (graphics-set-grid-astep "24" #f))
> ---
> ("4" (graphics-set-grid-astep "4" #f))
> ("6" (graphics-set-grid-astep "6" #f))
> ("8" (graphics-set-grid-astep "8" #f))
> ("12" (graphics-set-grid-astep "12" #f))
> ("16" (graphics-set-grid-astep "16" #f))
> ("24" (graphics-set-grid-astep "24" #f))
> ("30" (graphics-set-grid-astep "30" #f))
> ("36" (graphics-set-grid-astep "36" #f))
> ("60" (graphics-set-grid-astep "60" #f))
> ---
> ("Other" (graphics-interactive-set-grid-astep #f))))
> (when (== (graphics-get-grid-type #f) 'logarithmic)
> (-> "Logarithmic base"
> ("Default" (graphics-set-grid-base "10" #f))
> ---
> ("6" (graphics-set-grid-base "6" #f))
> ("8" (graphics-set-grid-base "8" #f))
> ("10" (graphics-set-grid-base "10" #f))
> ("16" (graphics-set-grid-base "16" #f))
> ---
> ("Other" (graphics-interactive-set-grid-base #f))))
> (when (or (== (graphics-get-grid-type #f) 'cartesian)
> (== (graphics-get-grid-type #f) 'polar)
> )
> (-> "Number of subunit steps"
> ("Default" (graphics-set-grid-aspect 'detailed #f #f))
> ---
> ("2" (graphics-set-grid-aspect 'detailed 2 #f))
> ("3" (graphics-set-grid-aspect 'detailed 3 #f))
> ("4" (graphics-set-grid-aspect 'detailed 4 #f))
> ("5" (graphics-set-grid-aspect 'detailed 5 #f))
> ("6" (graphics-set-grid-aspect 'detailed 6 #f))
> ("8" (graphics-set-grid-aspect 'detailed 8 #f))
> ("10" (graphics-set-grid-aspect 'detailed 10 #f))
> ---
> ("Other" (graphics-interactive-set-grid-nsubds #f)))))
>
> (menu-bind graphics-grids-menu
> ("Default" (graphics-reset-grids))
> ---
> (link graphics-visual-grid-menu))
>
> (menu-bind graphics-mode-menu
> ("Point" (graphics-set-mode '(edit point)))
> ("Line" (graphics-set-mode '(edit line)))
> ("Polygon" (graphics-set-mode '(edit cline)))
> ("Spline" (graphics-set-mode '(edit spline)))
> ("Closed spline" (graphics-set-mode '(edit cspline)))
> ("Arc" (graphics-set-mode '(edit arc)))
> ("Circle" (graphics-set-mode '(edit carc)))
> ("Text" (graphics-set-mode '(edit text-at)))
> ("Mathematics" (graphics-set-mode '(edit math-at)))
> (assuming (style-has? "std-markup-dtd")
> ---
> ;; (for (tag (sort gr-tags-user symbol<=?))
> ;; ((eval (upcase-first (symbol->string tag)))
> ;; (graphics-set-mode `(edit ,tag)))))
>
> (-> "Constructions"
> (-> "Codages"
> ("Angle droit ABC" (graphics-set-mode '(edit rightangle))))
> (-> "Points"
> ("Milieu de AB" (graphics-set-mode '(edit middle)))
> ("Centre de gravite de ABC" (graphics-set-mode '(edit gravity))))
> (-> "Droites"
> ("Perpendiculaire a AB passant par C" (graphics-set-mode '(edit
> perpendicular)))
> ("Parallele a AB passant par C" (graphics-set-mode '(edit
> parallel)))
> ---
> ("Mediatrice de AB" (graphics-set-mode '(edit mediator)))
> ("Bissectrice de ABC" (graphics-set-mode '(edit bissector))))
> (-> "Cercles"
> ("Cercle de centre C passant par A" (graphics-set-mode '(edit
> circle)))
> ("Cercle de diametre AB" (graphics-set-mode '(edit circle2))))
> (-> "Triangles"
> ("Triangle ABC equilateral" (graphics-set-mode '(edit equilateral)))
> ("Triangle ABC iscocele en B" (graphics-set-mode '(edit
> isosceles2)))
> ("Triangle ABC iscocele en C" (graphics-set-mode '(edit isosceles)))
> ("Triangle ABC rectangle en B" (graphics-set-mode '(edit
> right-angled-triangle)))
> ("Triangle ABC rectangle en C" (graphics-set-mode '(edit
> right-angled-triangle2))))
> (-> "Quadrilaterals"
> ("Carre ABCD" (graphics-set-mode '(edit square)))
> ("Rectangle horizontal ABCD de diagonale AC" (graphics-set-mode
> '(edit rectangle)))
> ("Rectangle ABCD connaissant A B C" (graphics-set-mode '(edit
> rectangle2))))
> (-> "Polygones reguliers"
> ("Pentagone ABCDE connaissant A B" (graphics-set-mode '(edit
> pentagon)))
> ("Hexagone ABCDEF connaissant A B" (graphics-set-mode '(edit
> hexagon)))))
> (-> "Electronic"
> ("Condensateur" (graphics-set-mode '(edit condensator)))
> ("Diode" (graphics-set-mode '(edit diode))))
> )
> ---
> ("Set properties" (graphics-set-mode '(group-edit props)))
> ("Move objects" (graphics-set-mode '(group-edit move)))
> ("Resize objects" (graphics-set-mode '(group-edit zoom)))
> ("Rotate objects" (graphics-set-mode '(group-edit rotate)))
> ("Group/ungroup" (graphics-set-mode '(group-edit group-ungroup))))
>
> (menu-bind graphics-opacity-menu
> ("0%" (graphics-set-opacity "0%"))
> ("10%" (graphics-set-opacity "10%"))
> ("20%" (graphics-set-opacity "20%"))
> ("30%" (graphics-set-opacity "30%"))
> ("40%" (graphics-set-opacity "40%"))
> ("50%" (graphics-set-opacity "50%"))
> ("60%" (graphics-set-opacity "60%"))
> ("70%" (graphics-set-opacity "70%"))
> ("80%" (graphics-set-opacity "80%"))
> ("90%" (graphics-set-opacity "90%"))
> ("100%" (graphics-set-opacity "100%"))
> ---
> ("Other" (interactive graphics-set-opacity)))
>
> (menu-bind graphics-color-menu
> ;;("Default" (graphics-set-color "default"))
> ("None" (graphics-set-color "none"))
> ---
> (pick-color
> (let* ((a answer)
> (s (if (or (== a "black") (== a "#000000")) "default" a)))
> (graphics-set-color a)))
> ---
> ("Palette" (interactive-color (lambda (c) (graphics-set-color c)) '()))
> ("Other" (interactive graphics-set-color)))
>
> (menu-bind grid-color-axes-menu
> ("Default" (graphics-set-grid-color 'axes "default"))
> ---
> (pick-color (graphics-set-grid-color 'axes answer))
> ---
> ("Palette" (interactive-color
> (lambda (c) (graphics-set-grid-color 'axes c)) '()))
> ("Other" (interactive
> (lambda (x) (graphics-set-grid-color 'axes x)) "Color")))
>
> (menu-bind grid-color-units-menu
> ("Default" (graphics-set-grid-color 'units "default"))
> ---
> (pick-color (graphics-set-grid-color 'units answer))
> ---
> ("Palette" (interactive-color
> (lambda (c) (graphics-set-color 'units c)) '()))
> ("Other" (interactive
> (lambda (x) (graphics-set-grid-color 'units x)) "Color")))
>
> (menu-bind grid-color-subunits-menu
> ("Default" (graphics-set-grid-color 'subunits "default"))
> ---
> (pick-color (graphics-set-grid-color 'subunits answer))
> ---
> ("Palette" (interactive-color
> (lambda (c) (graphics-set-grid-color 'subunits c)) '()))
> ("Other" (interactive
> (lambda (x) (graphics-set-grid-color 'subunits x)) "Color")))
>
> (menu-bind graphics-point-style-menu
> ;;("Default" (graphics-set-point-style "default"))
> ;;---
> ;;("Disk" (graphics-set-point-style "disk"))
> ("Disk" (graphics-set-point-style "default"))
> ("Round" (graphics-set-point-style "round"))
> ("Square" (graphics-set-point-style "square")))
>
> (menu-bind graphics-line-width-menu
> ;;("Default" (graphics-set-line-width "default"))
> ;;---
> ("0.5 ln" (graphics-set-line-width "0.5ln"))
> ;;("1 ln" (graphics-set-line-width "1ln"))
> ("1 ln" (graphics-set-line-width "default"))
> ("2 ln" (graphics-set-line-width "2ln"))
> ("5 ln" (graphics-set-line-width "5ln"))
> ---
> ("Other" (interactive graphics-set-line-width)))
>
> (menu-bind graphics-dash-menu
> (group "Style")
> ;;("Default" (graphics-set-dash-style "default"))
> ;;--
> ("-----" (graphics-set-dash-style "default"))
> (". . . . ." (graphics-set-dash-style "10"))
> ("- - - - -" (graphics-set-dash-style "11100"))
> ("- . - . -" (graphics-set-dash-style "1111010"))
> ;;---
> ;;("Other" (interactive graphics-set-dash-style_))
> ---
> (group "Unit")
> ;;("Default" (graphics-set-dash-style-unit "default"))
> ;;---
> ("2 ln" (graphics-set-dash-style-unit "2ln"))
> ("5 ln" (graphics-set-dash-style-unit "5ln"))
> ("10 ln" (graphics-set-dash-style-unit "10ln"))
> ---
> ("Other" (interactive graphics-set-dash-style-unit)))
>
> (menu-bind graphics-line-arrows-menu
> (group "Right arrow")
> ("None" (graphics-set-arrow-end "default"))
> ("--->" (graphics-set-arrow-end "<gtr>"))
> ("---|>" (graphics-set-arrow-end "|<gtr>"))
> ("--->>" (graphics-set-arrow-end "<gtr><gtr>"))
> ("---<" (graphics-set-arrow-end "<less>"))
> ("---<|" (graphics-set-arrow-end "<less>|"))
> ("---<<" (graphics-set-arrow-end "<less><less>"))
> ("---|" (graphics-set-arrow-end "|"))
> ("---o" (graphics-set-arrow-end "o"))
> ---
> (group "Left arrow")
> ("None" (graphics-set-arrow-begin "default"))
> ("<---" (graphics-set-arrow-begin "<less>"))
> ("<|---" (graphics-set-arrow-begin "<less>|"))
> ("<<---" (graphics-set-arrow-begin "<less><less>"))
> (">---" (graphics-set-arrow-begin "<gtr>"))
> ("|>---" (graphics-set-arrow-begin "|<gtr>"))
> (">>---" (graphics-set-arrow-begin "<gtr><gtr>"))
> ("|---" (graphics-set-arrow-begin "|"))
> ("o---" (graphics-set-arrow-begin "o")))
>
> (menu-bind graphics-fill-color-menu
> ;;("Default" (graphics-set-fill-color "default"))
> ;;("None" (graphics-set-fill-color "none"))
> ("None" (graphics-set-fill-color "default"))
> ---
> (pick-color (graphics-set-fill-color answer))
> ;;(pick-background (graphics-set-fill-color answer))
> ---
> ("Palette" (interactive-color (lambda (c) (graphics-set-fill-color c)) '()))
> ("Other" (interactive graphics-set-fill-color)))
>
> (menu-bind graphics-text-halign-menu
> ;;("Default" (graphics-set-text-at-halign "default"))
> ;;---
> ;;("Left" (graphics-set-text-at-halign "left"))
> ("Left" (graphics-set-text-at-halign "default"))
> ("Center" (graphics-set-text-at-halign "center"))
> ("Right" (graphics-set-text-at-halign "right")))
>
> (menu-bind graphics-text-valign-menu
> ;;("Default" (graphics-set-text-at-valign "default"))
> ;;---
> ("Bottom" (graphics-set-text-at-valign "bottom"))
> ;;("Base" (graphics-set-text-at-valign "base"))
> ("Base" (graphics-set-text-at-valign "default"))
> ("Axis" (graphics-set-text-at-valign "axis"))
> ("Center" (graphics-set-text-at-valign "center"))
> ("Top" (graphics-set-text-at-valign "top")))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Menus for graphics mode
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (menu-bind graphics-insert-menu
> (-> "Geometry" (link graphics-global-menu))
> (-> "Grid" (link graphics-grids-menu))
> ---
> (link graphics-mode-menu))
>
> (menu-bind graphics-focus-menu
> (-> (eval (upcase-first (gr-mode->string (graphics-mode))))
> (link graphics-mode-menu))
> (assuming (nnull? (graphics-mode-attributes (graphics-mode)))
> ---
> (assuming (graphics-mode-attribute? (graphics-mode) "color")
> (-> "Color" (link graphics-color-menu)))
> (assuming (graphics-mode-attribute? (graphics-mode) "fill-color")
> (-> "Fill color" (link graphics-fill-color-menu)))
> (assuming (graphics-mode-attribute? (graphics-mode) "opacity")
> (assuming (== (get-preference "experimental alpha") "on")
> (-> "Opacity" (link graphics-opacity-menu))))
> (assuming (graphics-mode-attribute? (graphics-mode) "point-style")
> (-> "Point style" (link graphics-point-style-menu)))
> (assuming (graphics-mode-attribute? (graphics-mode) "line-width")
> (-> "Line width" (link graphics-line-width-menu)))
> (assuming (graphics-mode-attribute? (graphics-mode) "dash-style")
> (-> "Line dashes" (link graphics-dash-menu)))
> (assuming
> (or (graphics-mode-attribute? (graphics-mode) "arrow-begin")
> (graphics-mode-attribute? (graphics-mode) "arrow-end"))
> (-> "Line arrows" (link graphics-line-arrows-menu)))
> (assuming (graphics-mode-attribute? (graphics-mode) "text-at-halign")
> (-> "Horizontal alignment" (link graphics-text-halign-menu)))
> (assuming (graphics-mode-attribute? (graphics-mode) "text-at-valign")
> (-> "Vertical alignment" (link graphics-text-valign-menu)))))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;; Icons for graphics mode
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
>
> (tm-menu (graphics-global-icons)
> (=> (balloon (icon "tm_graphics_geometry.xpm") "Graphics geometry")
> (link graphics-global-menu))
> (=> (balloon (icon "tm_graphics_grid.xpm") "Graphics grids")
> (link graphics-grids-menu)))
>
> (tm-menu (graphics-insert-icons)
> ;;(=> (balloon (icon "tm_cell_special.xpm") "Graphical mode")
> ;; (link graphics-mode-menu))
> ((check (balloon (icon "tm_point_mode.xpm") "Insert points")
> "v" (== (graphics-mode) '(edit point)))
> (graphics-set-mode '(edit point)))
> ((check (balloon (icon "tm_line_mode.xpm") "Insert lines")
> "v" (== (graphics-mode) '(edit line)))
> (graphics-set-mode '(edit line)))
> ((check (balloon (icon "tm_cline_mode.xpm") "Insert polygons")
> "v" (== (graphics-mode) '(edit cline)))
> (graphics-set-mode '(edit cline)))
> ((check (balloon (icon "tm_spline_mode.xpm") "Insert splines")
> "v" (== (graphics-mode) '(edit spline)))
> (graphics-set-mode '(edit spline)))
> ((check (balloon (icon "tm_cspline_mode.xpm") "Insert closed splines")
> "v" (== (graphics-mode) '(edit cspline)))
> (graphics-set-mode '(edit cspline)))
> ((check (balloon (icon "tm_arc_mode.xpm") "Insert arcs")
> "v" (== (graphics-mode) '(edit arc)))
> (graphics-set-mode '(edit arc)))
> ((check (balloon (icon "tm_carc_mode.xpm") "Insert circles")
> "v" (== (graphics-mode) '(edit carc)))
> (graphics-set-mode '(edit carc)))
> ((check (balloon (icon "tm_textat_mode.xpm") "Insert text")
> "v" (== (graphics-mode) '(edit text-at)))
> (graphics-set-mode '(edit text-at)))
> ((check (balloon (icon "tm_math.xpm") "Insert mathematics")
> "v" (== (graphics-mode) '(edit math-at)))
> (graphics-set-mode '(edit math-at))))
>
> (tm-menu (graphics-group-property-icons)
> ((check (balloon (icon "tm_edit_props.xpm") "Change objects properties")
> "v" (== (graphics-mode) '(group-edit props)))
> (graphics-set-mode '(group-edit props))))
>
> (tm-menu (graphics-group-icons)
> ((check (balloon (icon "tm_group_move.xpm") "Move objects")
> "v" (== (graphics-mode) '(group-edit move)))
> (graphics-set-mode '(group-edit move)))
> ((check (balloon (icon "tm_group_zoom.xpm") "Zoom/unzoom objects")
> "v" (== (graphics-mode) '(group-edit zoom)))
> (graphics-set-mode '(group-edit zoom)))
> ((check (balloon (icon "tm_group_rotate.xpm") "Rotate objects")
> "v" (== (graphics-mode) '(group-edit rotate)))
> (graphics-set-mode '(group-edit rotate)))
> ((check (balloon (icon "tm_group_group.xpm") "Group/ungroup objects")
> "v" (== (graphics-mode) '(group-edit group-ungroup)))
> (graphics-set-mode '(group-edit group-ungroup))))
>
> (tm-menu (graphics-property-icons)
> (assuming (graphics-mode-attribute? (graphics-mode) "color")
> /
> (mini #t
> (group "Color:")
> (with col (graphics-get-property "gr-color")
> (assuming (== col "default")
> (=> (color "black" #f #f 25 17)
> (link graphics-color-menu)))
> (assuming (== col "none")
> (=> "none"
> (link graphics-color-menu)))
> (assuming (and (!= col "default") (!= col "none"))
> (=> (color (eval col) #f #f 25 17)
> (link graphics-color-menu))))))
> (assuming (graphics-mode-attribute? (graphics-mode) "fill-color")
> /
> (mini #t
> (group "Fill color:")
> (with col (graphics-get-property "gr-fill-color")
> (assuming (== col "default")
> (=> "none"
> (link graphics-fill-color-menu)))
> (assuming (== col "none")
> (=> "none"
> (link graphics-fill-color-menu)))
> (assuming (and (!= col "default") (!= col "none"))
> (=> (color (eval col) #f #f 25 17)
> (link graphics-fill-color-menu))))))
> (assuming (== (get-preference "experimental alpha") "on")
> (assuming (graphics-mode-attribute? (graphics-mode) "opacity")
> /
> (mini #t
> (group "Opacity:")
> (let* ((o (graphics-get-property "gr-opacity"))
> (s (if (== o "default") "100%" o)))
> (=> (eval s)
> (link graphics-opacity-menu))))))
> (assuming (graphics-mode-attribute? (graphics-mode) "point-style")
> /
> (mini #t
> (group "Point style:")
> (let* ((ps (graphics-get-property "gr-point-style"))
> (s (if (== ps "default") "disk" ps)))
> (=> (eval s)
> (link graphics-point-style-menu)))))
> (assuming
> (or (graphics-mode-attribute? (graphics-mode) "line-width")
> (graphics-mode-attribute? (graphics-mode) "dash-style"))
> /
> (mini #t
> (group "Line style:")
> (let* ((lw (graphics-get-property "gr-line-width"))
> (s (if (== lw "default") "1ln" lw)))
> (=> (eval s)
> (link graphics-line-width-menu)))
> (let* ((dash (graphics-get-property "gr-dash-style"))
> (s (decode-dash dash)))
> (=> (eval s)
> (link graphics-dash-menu)))))
> (assuming
> (or (graphics-mode-attribute? (graphics-mode) "arrow-begin")
> (graphics-mode-attribute? (graphics-mode) "arrow-end"))
> /
> (mini #t
> (group "Arrows:")
> (let* ((arrow-begin (graphics-get-property "gr-arrow-begin"))
> (arrow-end (graphics-get-property "gr-arrow-end"))
> (s (string-append (decode-arrow arrow-begin)
> "---"
> (decode-arrow arrow-end))))
> (=> (eval s)
> (link graphics-line-arrows-menu)))))
> (assuming (or (graphics-mode-attribute? (graphics-mode) "text-at-halign")
> (graphics-mode-attribute? (graphics-mode) "text-at-valign"))
> /
> (mini #t
> (group "Alignment:")
> (let* ((al (graphics-get-property "gr-text-at-halign"))
> (s (if (== al "default") "left" al)))
> (=> (eval s)
> (link graphics-text-halign-menu)))
> (let* ((al (graphics-get-property "gr-text-at-valign"))
> (s (if (== al "default") "base" al)))
> (=> (eval s)
> (link graphics-text-valign-menu))))))
>
> (define (gr-mode->string s)
> (cond ((== s '(edit point)) "point")
> ((== s '(edit line)) "line")
> ((== s '(edit cline)) "polygon")
> ((== s '(edit spline)) "spline")
> ((== s '(edit cspline)) "closed spline")
> ((== s '(edit arc)) "arc")
> ((== s '(edit carc)) "circle")
> ((== s '(edit text-at)) "text")
> ((== s '(edit math-at)) "mathematics")
> ((== s '(group-edit props)) "properties")
> ((== s '(group-edit move)) "move")
> ((== s '(group-edit zoom)) "resize")
> ((== s '(group-edit rotate)) "rotate")
> ((== s '(group-edit group-ungroup)) "group/ungroup")
> ((and (list-2? s) (== (car s) 'edit) (in? (cadr s) gr-tags-user))
> (symbol->string (cadr s)))
> (else "unknown")))
>
> (tm-menu (graphics-icons)
> (link graphics-global-icons)
> /
> (link graphics-insert-icons)
> /
> (link graphics-group-property-icons)
> (link graphics-group-icons))
>
> (tm-menu (graphics-focus-icons)
> (mini #t
> (=> (balloon (eval (upcase-first (gr-mode->string (graphics-mode))))
> "Current graphical mode")
> (link graphics-mode-menu)))
> (assuming (nnull? (graphics-mode-attributes (graphics-mode)))
> (link graphics-property-icons)))