; ------------------------------------------------------------------------------

  ;             GITTERKREUZRASTER GENERIEREN
  ;             VERSION : 31.01.2000
  ;             AUTOR   : Mario Tröger  www.the-skier.de

  ; ------------------------------------------------------------------------------
(prompt "\nGITTER_MT.lsp  copyright © by Mario Tröger www.the-skier.de")
(defun
   C:GITTER_MT
              (/
               ag		 m			einfm	 lu			lo		 ro			ru
							 ymax		xmax	 ymin		xmin	 luy		roy		 loy		luy
							 rox		rux		 lux		lox		 rymx		rxmx	 rymn		rxmn
							 sy			sx		 ep			sspr	 w1			w2		 w3			w4
							 w0			w90ru1 ru2		ro1		 ro2		lu1		 lu2		lo1
							 lo2		ruh		 roh		luh		 loh		rur		 ror		lur
							 lor		ruh1	 luh1		lur1	 lor1		ruhp1	 ruhp2	luhp1
							 luhp2	lurp1	 lurp2	lorp1	 lorp2	rw1		 rw2		lw1
							 lw2		hw		 rw			rw1txt rw2txt	rw3txt hw1txt	hw2txt
							 hw3txt	eptxt
               )
  (SVAR_INP
    '("cmdecho" "blipmode" "pdmode" "pdsize" "osmode")
    ) ;_ Ende von SVAR_INP
  (SVAR_PUT)
  (MAIN_G)
  (SVAR_OUT *SVIN)
  (princ "\n*** Programm ENDE ***")
  (prin1)
  ) ;_ Ende von DEFUN

  ; ------------------------------------------------------------------------------

  ;             HAUPTPROGRAMM

(defun
   MAIN_G
         (/)
  (princ "\n>> GITTERKREUZRASTER GENERIEREN <<")
  (setq AG (getint "\nRasterabstand [m] : "))
  (setq M (getreal "\nMaßstab 1 : "))
  (setq EINFM (/ M 1000))
  (setq BRTXT (getreal "\nRahmenbreite für Beschriftung [mm]:"))
  (setq GITTBL (strcat "GITTER"))
  (setq STILH (* 1.5 EINFM))
  (command "STIL" "G15S" "ROMANS.SHX" STILH 0.8 "" "" "" "")
  (LAY)
  (BLATT)
  (GIT_RAST)
  (GIT_ENTF)
  (GIT_TXT)
  ) ;_ Ende von DEFUN

  ; ------------------------------------------------------------------------------
  ; FUNKTION LAYER FÜR GITTER EINFÜGUNG
  ; SETZEN

(defun
   AIB
      (W)
  (* pi (/ W 180.0))
  ) ;_ Ende von defun

(defun
   LAY
      (/)
  (setq LAYOLD (getvar "CLAYER"))
  (command "_-LAYER" "SETZEN" "GITTER" "")
  ) ;_ Ende von DEFUN

  ; ------------------------------------------------------------------------------
  ; FUNKTION BLATTSPIEGELECKPUNKTE
  ; EINGEBEN
(defun
   BLATT
        (/)
  (setvar "osmode" 33)
  (setq
    RU (getpoint "\nBlattspiegel   rechts unten   anwählen :")
    RO (getpoint "\nBlattspiegel   näcsten entgen UZS   anwählen :")
    LO (getpoint "\nBlattspiegel   näcsten entgegen UZS   anwählen :")
    LU (getpoint "\nBlattspiegel   näcsten entgegen UZS   anwählen :")
    ) ;_ Ende von setq
  (setvar "osmode" 0)
  (setq
    LUY (cadr LU)
    LOY (cadr LO)
    ROY (cadr RO)
    RUY (cadr RU)
    ) ;_ Ende von setq
  (setq
    LUX (car LU)
    LOX (car LO)
    ROX (car RO)
    RUX (car RU)
    ) ;_ Ende von setq
  (setq
    YMAX (max LUY LOY ROY RUY)
    YMIN (min LUY LOY ROY RUY)
    ) ;_ Ende von setq
  (setq
    XMAX (max LUX LOX ROX RUX)
    XMIN (min LUX LOX ROX RUX)
    ) ;_ Ende von setq
  ) ;_ Ende von DEFUN

  ; ------------------------------------------------------------------------------
  ;             FUNKTION GITTERRASTER
(defun
   GIT_RAST
           (/)
  (setq RYMX YMAX)
  (setq RYMN (* (fix (/ YMIN 100)) 100))
  (setq RXMX XMAX)
  (setq RXMN (* (fix (/ XMIN 100)) 100))
  (setq SY RYMN)
  (while (< SY YMAX)
    (setq SX RXMN)
    (while (< SX XMAX)
      (setq EP (list SX SY 0))
      (command "_-INSERT" GITTBL EP EINFM EINFM 0)
      (setq SX (+ SX AG))
      ) ;_ Ende von while
    (setq SY (+ SY AG))
    ) ;_ Ende von while
  ) ;_ Ende von DEFUN

  ; ------------------------------------------------------------------------------
  ; FUNKTION ÜBERSTEHENDE GITTERKREUZE
  ; LÖSCHEN

(defun
   GIT_ENTF
           (/)
  (setq SSPR (ssget "X" '((0 . "INSERT") (2 . "GITTER"))))
  (command "LÖSCHEN" SSPR "E" "KP" RU RO LO LU "" "")
  ) ;_ Ende von DEFUN

  ; ------------------------------------------------------------------------------
  ;            FUNKTION BESCHRIFTUNG

(defun
   GIT_TXT
          (/)
  (setq W1 (angle RU RO))
  (setq W2 (angle RO LO))
  (setq W3 (angle LO LU))
  (setq W4 (angle LU RU))
  (setq RU1 (polar RU W4 BRTXT))
  (setq RU2 (polar RU1 W3 BRTXT))
  (setq RO1 (polar RO W4 BRTXT))
  (setq RO2 (polar RO1 W1 BRTXT))
  (setq LO1 (polar LO W2 BRTXT))
  (setq LO2 (polar LO1 W1 BRTXT))
  (setq LU1 (polar LU W2 BRTXT))
  (setq LU2 (polar LU1 W3 BRTXT))
  (setvar "OSMODE" 0)
  (setq RUH (cadr RU)) ;	Hochwert ru
  (setq RUR (car RU)) ;	Rechtswert ru
  (setq RUH1 (* (fix (/ RUH 100)) 100))
  ;	Hochwert ru auf volle 100 gerunder
  (setq ROH (cadr RO)) ;	Hochwert ro
  (while (< RUH1 RUH)
    (setq RUH1 (+ RUH1 AG)) ; Rechtsw auf volle 100 mit größer ru
    ) ;_ Ende von if
  (while (<= RUH1 ROH)
    (setvar "OSMODE" 0)
    (setq RUHP1 (list RUR RUH1)) ; Punkt puhP1   mit Rechtsw ru
  ; + Hochwert gerundet auf 100 mit > ru
    (setq W0 (angtof "0" 3)) ; Winkel 0 als Bogenmaß gesetzt
    (setq RUHP2 (polar RUHP1 W0 20)) ;	Punkt ruhP2
    (setq RW1 (inters RU RO RUHP1 RUHP2 NIL)) ; Schmittpunkt  rw1
    (setq RW2 (inters RU2 RO2 RUHP1 RUHP2 NIL)) ; Schnittpunkt  rw2
    (setq HW (rtos RUH1 2 0)) ; Hochwert runden für Text
    (command "LINIE" RW1 RW2 "") ; Kooranstrich zeichnen
    (setq RW1TXT (car RW1))
    (setq RW2TXT (car RW2))
    (setq RW3TXT (/ (+ RW1TXT RW2TXT) 2))
  ;	Mittelpunkt des Anstriches ermittelt
    (setq EPTXT (list RW3TXT RUH1))
    (command "TEXT" "P" "UZ" EPTXT 0 HW ) ;	Koor anschreiben
    (setq RUH1 (+ RUH1 AG)) ;	Hochwert um 100 erhöhen
    ) ;_ Ende von while
  (setq LUH (cadr LU)) ;	Hochwert lu
  (setq LUR (car LU)) ;	Rechtswert lu
  (setq LUH1 (* (fix (/ LUH 100)) 100))
  ;	Hochwert lu auf volle 100 gerunder
  (setq LOH (cadr LO)) ;	Hochwert lo
  (while (< LUH1 LUH)
    (setq LUH1 (+ LUH1 AG)) ; Rechtsw auf volle 100 mit größer ru
    ) ;_ Ende von While
  (while (<= LUH1 LOH)
    (setvar "OSMODE" 0)
    (setq LUHP1 (list LUR LUH1)) ; Punkt luhP1   mit Rechtsw lu
  ; + Hochwert gerundet auf 100 mit > lu
    (setq LUHP2 (polar LUHP1 W0 20)) ;	Punkt luhP2
    (setq LW1 (inters LU LO LUHP1 LUHP2 NIL)) ; Schmittpunkt  lw1
    (setq LW2 (inters LU2 LO2 LUHP1 LUHP2 NIL)) ;  Schnittpunkt  lw2
    (setq HW (rtos LUH1 2 0)) ;  Hochwert runden für Text
    (command "LINIE" LW1 LW2 "") ;  Kooranstrich zeichnen
    (setq RW1TXT (car LW1))
    (setq RW2TXT (car LW2))
    (setq RW3TXT (/ (+ RW1TXT RW2TXT) 2))
  ;	Mittelpunkt des Anstriches ermittelt
    (setq EPTXT (list RW3TXT LUH1))
    (command "TEXT" "P" "UZ" EPTXT 0 HW ) ;	Koor anschreiben
    (setq LUH1 (+ LUH1 AG)) ;	Hochwert um 100 erhöhen
    ) ;_ Ende von while
  (setq LOR (car LO)) ;	Rechtswert lo
  (setq LOH (cadr LO)) ;	Hochwert lo
  (setq LOR1 (* (fix (/ LOR 100)) 100))
  ;	Rechtswert lo auf volle 100 gerunder
  (setq ROR (car RO)) ;	Rechtswert ro
  (while (< LOR1 LOR)
    (setq LOR1 (+ LOR1 AG)) ; Rechtsw auf volle 100 mit größer lo
    ) ;_ Ende von While
  (while (<= LOR1 ROR)
    (setvar "OSMODE" 0)
    (setq LORP1 (list LOR1 LOH)) ; Punkt lorP1   mit Hochw lo
  ; + Rechtswert gerundet auf 100 mit > lo
    (setq W90 (+ W0 (AIB 90))) ; Winkel 90 als Bogenmaß gesetzt
    (setq LORP2 (polar LORP1 W90 20)) ;	Punkt lorP2
    (setq RW1 (inters LO RO LORP1 LORP2 NIL)) ; Schmittpunkt  rw1
    (setq RW2 (inters LO2 RO2 LORP1 LORP2 NIL)) ; Schnittpunkt  rw2
    (setq RW (rtos LOR1 2 0)) ; Rechtswert runden für Text
    (command "LINIE" RW1 RW2 "") ; Kooranstrich zeichnen
    (setq HW1TXT (cadr RW1))
    (setq HW2TXT (cadr RW2))
    (setq HW3TXT (/ (+ HW1TXT HW2TXT) 2))
  ;	Mittelpunkt des Anstriches ermittelt
    (setq EPTXT (list LOR1 HW3TXT))
    (command "TEXT" "P" "UZ" EPTXT 270 RW ) ;	Koor anschreiben
    (setq LOR1 (+ LOR1 AG)) ;	Rechtswert um 100 erhöhen
    ) ;_ Ende von while
  (setq LUR (car LU)) ;	Rechtswert lu
  (setq LUH (cadr LU)) ;	Hochwert lu
  (setq LUR1 (* (fix (/ LUR 100)) 100))
  ;	Rechtswert lu auf volle 100 gerunder
  (setq RUR (car RU)) ;	Rechtswert ru
  (while (< LUR1 LUR)
    (setq LUR1 (+ LUR1 AG)) ; Rechtsw auf volle 100 mit größer lu
    ) ;_ Ende von While
  (while (<= LUR1 RUR)
    (setvar "OSMODE" 0)
    (setq LURP1 (list LUR1 LUH)) ; Punkt lurP1   mit Hochw lo
  ; + Rechtswert gerundet auf 100 mit > lu
    (setq W90 (+ W0 (AIB 90))) ; Winkel 90 als Bogenmaß gesetzt
    (setq LURP2 (polar LURP1 W90 20)) ;	Punkt lurP2
    (setq RW1 (inters LU RU LURP1 LURP2 NIL)) ; Schmittpunkt  rw1
    (setq RW2 (inters LU2 RU2 LURP1 LURP2 NIL)) ; Schnittpunkt  rw2
    (setq RW (rtos LUR1 2 0)) ; Rechtswert runden für Text
    (command "LINIE" RW1 RW2 "") ; Kooranstrich zeichnen
    (setq HW1TXT (cadr RW1))
    (setq HW2TXT (cadr RW2))
    (setq HW3TXT (/ (+ HW1TXT HW2TXT) 2))
  ;	Mittelpunkt des Anstriches ermittelt
    (setq EPTXT (list LUR1 HW3TXT))
    (command "TEXT" "P" "UZ" EPTXT 270 RW ) ;	Koor anschreiben
    (setq LUR1 (+ LUR1 AG)) ;	Rechtswert um 100 erhöhen
    ) ;_ Ende von while
  (princ "\nENDE KOORDINATEN ANSCHREIBEN")
  (prin1)
  ) ;_ Ende von DEFUN

  ; ------------------------------------------------------------------------------
  ; FUNKTION AKTUELLE SYSTEMVARIABLE
  ; LESEN
(defun
   SVAR_INP
           (SV)

  (setq *SVIN '())
  (repeat (length SV)
    (setq
      *SVIN
       (append
         *SVIN
         (list (list (car SV) (getvar (car SV))))
         ) ;_ Ende von append
      ) ;_ Ende von setq
    (setq SV (cdr SV))
    ) ;_ Ende von repeat
  (setq LAYALT (getvar "CLAYER"))

  ) ;_ Ende von DEFUN

  ; ------------------------------------------------------------------------------

  ;             FUNKTION TEMPORAERE SYSTEMVARIABLE SETZEN

(defun
   SVAR_PUT
           ()

  (mapcar
    'setvar
    '("cmdecho" "cmddia" "blipmode" "pdmode" "pdsize" "osmode")
    '(0 0 0 3 0.3 32)
    ) ;_ Ende von mapcar

  ) ;_ Ende von DEFUN
  ; ------------------------------------------------------------------------------

  ;             FUNKTION ALTE SYSTEMVARIABLE SETZEN

(defun
   SVAR_OUT
           (SV)

  (setq LAYAKT (getvar "CLAYER"))
  (if (/= LAYAKT LAYALT)
    (command "_-LAYER" "SETZEN" LAYALT "")
    ) ;_ Ende von if
  (repeat (length SV)
    (setvar (caar SV) (cadar SV))
    (setq SV (cdr SV))
    ) ;_ Ende von repeat
  (setq *SVIN '())
  (princ)
  ) ;_ Ende von DEFUN

  ; ------------------------------------------------------------------------------

  ;             FEHLERROUTINE

;;;(DEFUN
;;;	 *error*
;;;					(msg)
;;;
;;;	(SVAR_OUT *svin)
;;;	(princ)
;;;
;;;) ;_ Ende von DEFUN
;|«Visual LISP© Format Options»
(100 2 2 1 T "end of " 100 2 1 2 0 nil T nil T)
;*** KEINEN Text unterhalb des Kommentars hinzufügen! ***|;