Author Topic: Unique xy point list but ignore z  (Read 7243 times)

0 Members and 1 Guest are viewing this topic.

XXL66

  • Newt
  • Posts: 99
Re: Unique xy point list but ignore z
« Reply #15 on: June 21, 2014, 10:51:15 AM »
no, because i need the HLS, that is the input i get.
but no worries, the doslib version is fine.

But other suggestions for improvement are welcome.  :-)

Code: [Select]
;*****************************************************************************;
; Initiated by XXL at TheSwamp                                                ;
;                                                                             ;
; June 2014                                                                   ;
; c:gcmap draws a gradient color map on a TIN                                  ;
; DOSLIB needs to be loaded for 'dos_hlstorgb' function                       ;
;*****************************************************************************;

(defun c:gcmap (/       col_Hb  col_He  col_L   col_S   s       i
       zl      ent     ival    Hue_i   TinMaxZ    TinMinZ    sug_ival
       hue_i
      )

  (setq col_Hb 0)
  ;; color min hue value
  (setq col_He 240)
  ;; color max hue value
  (setq col_L 120)
  ;; color light
  (setq col_S 240)
  ;; color saturation

  ;; select 3DFACES
  (setq s (ssget '((0 . "3DFACE"))))

  ;; make a list from every elevation value in the TIN
  (repeat (setq i (sslength s))
    (setq ent (ssname s (setq i (1- i))))
    (setq
      zl (append
   (mapcar 'cadddr
   (mapcar '(lambda (key) (assoc key (entget ent)))
   '(11 12 13)
   )
   )
   zl
)
    )
  )

  (setq TinMaxZ (apply 'max zl)
;; min TIN elevation
TinMinZ (apply 'min zl)
        ;; max TIN elevation
  )

  ;; compute an interval suggestion for about 20 levels
  (setq sug_ival (/ (- TinMaxZ TinMinZ) 20.0))
  ;; round to mm level
  (setq sug_ival (/ (fix (+ 0.5 (* sug_ival 1000.0))) 1000.0))
 
 
  ;; computed suggestion is rounded
  (cond ((> sug_ival 1.0)
(setq sug_ival (fix sug_ival))
)
((< sug_ival 0.099)
(setq sug_ival (/ (fix (+ 0.5 (* 100.0 sug_ival))) 100.0))
)
((< sug_ival 0.999)
(setq sug_ival (/ (fix (+ 0.5 (* 10.0 sug_ival))) 10.0))
)
  )
 
  ;; get user interval input and verify
  (while (not ival)
    (setq ival
   (getreal
     (strcat
       "\nEnter interval (suggested: "
       (rtos sug_ival 2 3)
       "m): "
     )
   )
    )
    (cond
      ((not ival)
       (setq ival sug_ival)
      )
      (t
       (progn
(if (> (/ (- TinMaxZ TinMinZ) ival) (- col_He col_Hb))
   (progn
     (alert
       "\nEntered interval is too small for color range, please choose a larger interval."
     )
     (setq ival nil)
   )
)
       )
      )
    )
  )
  (prompt (strcat "\nComputing "
  (rtos (/ (- TinMaxZ TinMinZ) ival) 2 0)
  " elevation levels... "
  )
  )
 
  ;; compute Hue increment for each elevation level based on color hue range, TIN delta elevation and interval
  (setq Hue_i (fix (/ (- col_He col_Hb) (/ (- TinMaxZ TinMinZ) ival))))
 
  ;; process every 3DFACE entity from selectionset s
  (repeat (setq i (sslength s))
    (setq ent (ssname s (setq i (1- i))))
    (trfill ent)
  )

  ;;; generate legend
;;;  (while (not (setq pt (getpoint "\nSelect position legend: "))))
;;;  (setq dval (* ival (+ 1 (fix (/ TinMinZ ival)))))
;;;  (setq x  (car pt)
;;; x1 (+ (car pt) 4.0)
;;; y  (cadr pt)
;;; y1 (+ (cadr pt) 1.0)
;;;  )
;;;  (repeat (fix (/ (- TinMaxZ TinMinZ) ival))
;;;    (progn
;;;      (setq
;;; cl (rgbtotruecolor
;;;      (dos_hlstorgb
;;;        (+ col_Hb (fix (* (/ (- dval TinMinZ) ival) Hue_i)))
;;;        col_L
;;;        col_S
;;;        
;;;        
;;;      )
;;;    )
;;;      )
;;;      (entmake (list (cons 0 "SOLID")
;;;      (cons 8 "LEGEND")
;;;      (cons 420 cl)
;;;      (cons 10 (list x y))
;;;      (cons 11 (list x y1))
;;;      (cons 12 (list x1 y))
;;;      (cons 13 (list x1 y1))
;;;        )
;;;      )
;;;      (setq dval$ (strcat "SOLID_" (rtos dval 2 2)))
;;;      (setq dval (+ ival dval)
;;;     y y1
;;;     y1 (+ y1 1.0)
;;;      )
;;;    )
;;;  )
;;; need to finish this


 
  (princ "done.")
  (princ)
)


;; fill every 3DFACE with gradient colors
(defun trfill (e / pl pi1 pi2 pi3 i1 i2 i3 minz maxz dval dval$ cl)
  ;; create pointlist from 3Dface
  (setq
    pl (mapcar
'cdr
(mapcar '(lambda (key) (assoc key (entget e))) '(11 12 13))
       )
  )
  (setq pl (vl-sort pl
    (function (lambda (a b) (< (caddr a) (caddr b))))
   )
  )

  ;; min and max elevation of 3Dface
  (setq minz (caddr (car pl)))
  (setq maxz (caddr (car (reverse pl))))

  (setq dval (* ival (+ 1 (fix (/ minz ival)))))
  (setq dval$ (strcat "SOLID_" (rtos (- dval ival) 2 2)))
  (if (>= dval maxz)
;;; there will be no intersections, colour the entire 3DFACE with a single solid
    (progn
      (setq
cl (rgbtotruecolor
     (dos_hlstorgb
       (+ col_Hb (fix (* (/ (- dval TinMinZ) ival) Hue_i)))
       col_L
       col_S
       
     )
   )
      )
      (entmake (list (cons 0 "SOLID")
     (cons 8 dval$)
     (cons 420 cl)
     (cons 10 (nth 0 pl))
     (cons 11 (nth 1 pl))
     (cons 12 (nth 2 pl))
     (cons 13 (nth 2 pl))
       )
      )
    )
    (progn
      (while (< dval maxz)
(progn
  (setq
    cl (rgbtotruecolor
(dos_hlstorgb
   (+ col_Hb (fix (* (/ (- dval TinMinZ) ival) Hue_i)))
   col_L
   col_S
   
)
       )
  )
  (setq
    i2 (inters (nth 0 pl)
       (nth 1 pl)
       (list (car (nth 0 pl)) (cadr (nth 0 pl)) dval)
       (list (car (nth 1 pl)) (cadr (nth 1 pl)) dval)
       t
       )
  )
  (setq
    i1 (inters (nth 0 pl)
       (nth 2 pl)
       (list (car (nth 0 pl)) (cadr (nth 0 pl)) dval)
       (list (car (nth 2 pl)) (cadr (nth 2 pl)) dval)
       t
       )
  )
  (setq
    i3 (inters (nth 1 pl)
       (nth 2 pl)
       (list (car (nth 1 pl)) (cadr (nth 1 pl)) dval)
       (list (car (nth 2 pl)) (cadr (nth 2 pl)) dval)
       t
       )
  )
  (cond ((and i1 i2)
(if (and (not pi1) (not pi2))
   ;; no previous intersections on edges
   (entmake (list (cons 0 "SOLID")
  (cons 8 dval$)
  (cons 420 cl)
  (cons 10 (nth 0 pl))
  (cons 11 i1)
  (cons 12 i2)
  (cons 13 i2)
    )
   )
   (entmake (list (cons 0 "SOLID")
  (cons 8 dval$)
  (cons 420 cl)
  (cons 10 pi1)
  (cons 11 i1)
  (cons 12 pi2)
  (cons 13 i2)
    )
   )
)
(setq pi1 i1
       pi2 i2
)
)
((and i1 i3)
(if (and (not pi1) (not pi2))
   ;; no previous intersections on edges
   (entmake (list (cons 0 "SOLID")
  (cons 8 dval$)
  (cons 420 cl)
  (cons 10 (nth 0 pl))
  (cons 11 i1)
  (cons 12 (nth 1 pl))
  (cons 13 i3)
    )
   )
   (progn
     (entmake (list (cons 0 "SOLID")
    (cons 8 dval$)
    (cons 420 cl)
    (cons 10 pi1)
    (cons 11 i1)
    (cons 12 pi2)
    (cons 13 i3)
      )
     )
     (if (< (caddr pi1) (caddr (nth 1 pl)))
       (entmake (list (cons 0 "SOLID")
      (cons 8 dval$)
      (cons 420 cl)
      (cons 10 pi2)
      (cons 11 i3)
      (cons 12 (nth 1 pl))
      (cons 13 (nth 1 pl))
)
       )
     )

   )
)
(setq pi1 i1
       pi2 i3
)
)

  )
  (setq dval$ (strcat "SOLID_" (rtos dval 2 2)))
  (setq dval (+ ival dval))
  (setq
    cl (rgbtotruecolor
(dos_hlstorgb
  (+ col_Hb (fix (* (/ (- dval TinMinZ) ival) Hue_i)))
   col_L
   col_S
 
)
       )
  )
  (if (>= dval maxz)
    (progn
      ;; draw last level
      (if i3
(entmake
  (list (cons 0 "SOLID")
(cons 8 dval$)
(cons 420 cl)
(cons 10 pi1)
(cons 11 pi2)
(cons 12 (nth 2 pl))
(cons 13 (nth 2 pl))
  )
)
(entmake
  (list (cons 0 "SOLID")
(cons 8 dval$)
(cons 420 cl)
(cons 10 pi1)
(cons 11 pi2)
(cons 12 (nth 2 pl))
(cons 13 (nth 1 pl))
  )
)
      )
    )
  )
)
      )
    )
  )
  (princ)
)

;; returns a integer for 420 dxf group code, input: rgb list
(defun RGBToTrueColor (rgb / tcol)
  (setq r (lsh (car rgb) 16))
  (setq g (lsh (cadr rgb) 8))
  (setq b (caddr rgb))
  (setq tcol (+ (+ r g) b))
)

(princ)

Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: Unique xy point list but ignore z
« Reply #16 on: June 21, 2014, 12:17:53 PM »
no, because i need the HLS, that is the input i get.
but no worries, the doslib version is fine.

Simply switch the order of the supplied arguments  :wink:

Here are some suggestions (untested):
Code: [Select]
;*****************************************************************************;
; Initiated by XXL at TheSwamp                                                ;
; Modified by Lee Mac 2014-06-21                                              ;
; ** DOSLIB no longer required **                                             ;
;                                                                             ;
; June 2014                                                                   ;
; c:gcmap draws a gradient color map on a TIN                                 ;
; DOSLIB needs to be loaded for 'dos_hlstorgb' function                       ;
;*****************************************************************************;

(defun c:gcmap ( / col_hb col_he col_l col_s e hue_i i ival s sug_ival tinmaxz tinminz zl )

    (setq col_Hb   0 ;; color min hue value
          col_He 360 ;; color max hue value
          col_L  100 ;; color light
          col_S  100 ;; color saturation
    )
    (if (setq s (ssget '((0 . "3DFACE"))))
        (progn
            (repeat (setq i (sslength s))
                (setq e  (entget (ssname s (setq i (1- i))))
                      zl (vl-list* (cadddr (assoc 11 e)) (cadddr (assoc 12 e)) (cadddr (assoc 13 e)) zl)
                )
            )
            (setq TinMaxZ  (apply 'max zl) ;; min TIN elevation
                  TinMinZ  (apply 'min zl) ;; max TIN elevation
                  sug_ival (/ (- TinMaxZ TinMinZ) 20.0)  ;; compute an interval suggestion for about 20 levels
                  sug_ival (/ (fix (+ 0.5 (* sug_ival 1000.0))) 1000.0) ;; round to mm level
                  sug_ival  ;; computed suggestion is rounded
                (cond
                    (   (> sug_ival 1.000) (fix sug_ival))
                    (   (< sug_ival 0.099) (/ (fix (+ 0.5 (* 100.0 sug_ival))) 100.0))
                    (   (< sug_ival 0.999) (/ (fix (+ 0.5 (* 10.0  sug_ival)))  10.0))
                )
            )
            ;; get user interval input and verify
            (while
                (and
                    (setq ival (getreal (strcat "\nEnter interval (suggested: " (rtos sug_ival 2 3) "m): ")))
                    (> (/ (- TinMaxZ TinMinZ) ival) (- col_He col_Hb))
                )
                (alert "\nEntered interval is too small for color range, please choose a larger interval.")
            )
            (if (null ival)
                (setq ival sug_ival)
            )
            (prompt (strcat "\nComputing " (rtos (/ (- TinMaxZ TinMinZ) ival) 2 0) " elevation levels... "))

            ;; compute Hue increment for each elevation level based on color hue range, TIN delta elevation and interval
            (setq Hue_i (fix (/ (- col_He col_Hb) (/ (- TinMaxZ TinMinZ) ival))))

            ;; process every 3DFACE entity from selectionset s
            (repeat (setq i (sslength s))
                (trfill (ssname s (setq i (1- i))))
            )
            (princ "Done.")
        )
    )
    (princ)
)

;; fill every 3DFACE with gradient colors
(defun trfill ( e / cl dval dval$ ex i1 i2 i3 maxz minz pi1 pi2 pl )
    ;; create pointlist from 3Dface
    (setq ex    (entget e)
          pl    (vl-sort (mapcar '(lambda ( x ) (cdr (assoc x ex))) '(11 12 13)) '(lambda ( a b ) (> (caddr a) (caddr b))))
          maxz  (caddar pl)  ;; min and max elevation of 3Dface
          minz  (caddr (last pl))
          dval  (* ival (+ 1 (fix (/ minz ival))))
          dval$ (strcat "SOLID_" (rtos (- dval ival) 2 2))
    )
    (if (>= dval maxz)
        ;;; there will be no intersections, colour the entire 3DFACE with a single solid
        (entmake
            (vl-list*
               '(0 . "SOLID")
                (cons 008 dval$)
                (cons 420 (apply 'LM:RGB->True (LM:HSL->RGB (+ col_Hb (fix (* (/ (- dval TinMinZ) ival) Hue_i))) col_S col_L)))
                (mapcar 'cons '(10 11 12 13) (reverse (cons (car pl) pl)))
            )
        )
        (progn
            (setq pl (reverse pl))
            (while (< dval maxz)
                (setq cl (apply 'LM:RGB->True (LM:HSL->RGB (+ col_Hb (fix (* (/ (- dval TinMinZ) ival) Hue_i))) col_S col_L))
                      i2 (inters (car  pl) (cadr   pl) (list (caar  pl) (cadar  pl) dval) (list (caadr pl)  (cadadr pl) dval) t)
                      i1 (inters (car  pl) (caddr  pl) (list (caar  pl) (cadar  pl) dval) (list (caaddr pl) (cadadr (cdr pl)) dval) t)
                      i3 (inters (cadr pl) (caddr  pl) (list (caadr pl) (cadadr pl) dval) (list (caaddr pl) (cadadr (cdr pl)) dval) t)
                )
                (cond
                    (   (and i1 i2)
                        (entmake
                            (vl-list* '(0 . "SOLID") (cons 008 dval$) (cons 420 cl)
                                (mapcar 'cons '(10 11 12 13)
                                    (if (and (not pi1) (not pi2)) ;; no previous intersections on edges
                                        (list (car pl) i1 i2 i2)
                                        (list pi1 i1 pi2 i2)
                                    )
                                )
                            )
                        )
                        (setq pi1 i1
                              pi2 i2
                        )
                    )
                    (   (and i1 i3)
                        (entmake
                            (vl-list* '(0 . "SOLID") (cons 008 dval$) (cons 420 cl)
                                (mapcar 'cons '(10 11 12 13)
                                    (if (and (not pi1) (not pi2)) ;; no previous intersections on edges
                                        (list (car pl) i1 (cadr pl) i3)
                                        (list pi1 i1 pi2 i3)
                                    )
                                )
                            )
                        )
                        (if (and pi1 pi2 (< (caddr pi1) (caddr (cadr pl))))
                            (entmake
                                (vl-list* '(0 . "SOLID") (cons 008 dval$) (cons 420 cl)
                                    (mapcar 'cons '(10 11 12 13) (list pi2 i3 (cadr pl) (cadr pl)))
                                )
                            )
                        )
                        (setq pi1 i1
                              pi2 i3
                        )
                    )
                )
                (setq dval$ (strcat "SOLID_" (rtos dval 2 2))
                      dval  (+ ival dval)
                      cl    (apply 'LM:RGB->True (LM:HSL->RGB (+ col_Hb (fix (* (/ (- dval TinMinZ) ival) Hue_i))) col_S col_L))
                )
                (if (>= dval maxz)
                    (entmake
                        (vl-list* '(0 . "SOLID") (cons 008 dval$) (cons 420 cl)
                            (mapcar 'cons '(10 11 12 13)
                                (if i3
                                    (list pi1 pi2 (caddr pl) (caddr pl))
                                    (list pi1 pi2 (caddr pl) (cadr  pl))
                                )
                            )
                        )
                    )
                )
            )
        )
    )
    (princ)
)

;; RGB -> True  -  Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values

(defun LM:RGB->True ( r g b )
    (logior (lsh (fix r) 16) (lsh (fix g) 8) (fix b))
)

;; HSL -> RGB  -  Lee Mac
;; Args: [int] 0<=h<=360, 0<=s<=100, 0<=l<=100
 
(defun LM:HSL->RGB ( h s l / u v )
    (setq h (/ h 360.0)
          s (/ s 100.0)
          l (/ l 100.0)
    )
    (mapcar '(lambda ( x ) (fix (+ 0.5 (* 255 x))))
        (cond
            (   (zerop s) (list l l l))
            (   (zerop l)'(0 0 0))
            (   (setq v (if (< l 0.5) (* l (1+ s)) (- (+ l s) (* l s)))
                      u (-  (* 2.0 l) v)
                )
                (mapcar
                   '(lambda ( h )
                        (setq h (rem (1+ h) 1))
                        (cond
                            (   (< (* 6.0 h) 1.0) (+ u (* 6.0 h (- v u))))
                            (   (< (* 2.0 h) 1.0) v)
                            (   (< (* 3.0 h) 2.0) (+ u (* 6.0 (- (/ 2.0 3.0) h) (- v u))))
                            (   u   )
                        )
                    )
                    (list (+ h (/ 1.0 3.0)) h (- h (/ 1.0 3.0)))
                )
            )
        )
    )
)

(princ)
« Last Edit: June 22, 2014, 08:50:43 AM by Lee Mac »

XXL66

  • Newt
  • Posts: 99
Re: Unique xy point list but ignore z
« Reply #17 on: June 21, 2014, 01:11:40 PM »
wow, thx ! you must be the Rossi of Lisp.
I swapped, i didn't work but probably swapped the wrong ones  :oops:, will try again.
I couldn't get your code to work, it gives error on i3 but i can't see what's wrong with it.


Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: Unique xy point list but ignore z
« Reply #18 on: June 21, 2014, 01:14:46 PM »
wow, thx ! you must be the Rossi of Lisp.

 :-)

I swapped, i didn't work but probably swapped the wrong ones  :oops:, will try again.
I couldn't get your code to work, it gives error on i3 but i can't see what's wrong with it.

Sorry, I modified the code very quickly - there was a typo (an extra 'd') -
I have now updated the above code, hopefully there are no more bugs!

XXL66

  • Newt
  • Posts: 99
Re: Unique xy point list but ignore z
« Reply #19 on: June 22, 2014, 02:42:33 AM »
thx, seems to work fine now but the colors are wierd, just like when i swapped the values.
Attached is an example TIN and the result with your code but with use of dos_hlstorgb (and swapped sl).

BTW: i see you use 008 for layer dxf group code instead of just 8, why is that ?

ty !

XXL66

  • Newt
  • Posts: 99
Re: Unique xy point list but ignore z
« Reply #20 on: June 22, 2014, 04:35:42 AM »
Another question, assuming you use VLIDE, what settings and where do i change to get the same formatting as your code ?
ty !

edit: i now compared the old code with yours and i find it strange that yours is slower although tightly written ?  :roll:

Command: GCMAP
Select objects: Specify opposite corner: 668 found
Select objects:
Enter interval (suggested: 0.070m): 0.0075
Computing 189 elevation levels... done.
Elapsed time: 4.2900 secs.

Command:
Command: U
Command: GCMAP_OLD
Select objects: Specify opposite corner: 668 found
Select objects:
Enter interval (suggested: 0.070m): 0.0075
Computing 189 elevation levels...
"\nElapsed time: 3.5570 secs." done.
« Last Edit: June 22, 2014, 04:56:00 AM by XXL66 »

Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: Unique xy point list but ignore z
« Reply #21 on: June 22, 2014, 08:54:25 AM »
thx, seems to work fine now but the colors are wierd, just like when i swapped the values.
Attached is an example TIN and the result with your code but with use of dos_hlstorgb (and swapped sl).

I have updated the colour parameter limits in the above posted code to:
Code: [Select]
    (setq col_Hb   0 ;; color min hue value
          col_He 360 ;; color max hue value
          col_L  100 ;; color light
          col_S  100 ;; color saturation
    )

Since these are the limits of the arguments for my LM:hsl->rgb function - maybe this will resolve the colour issues.

BTW: i see you use 008 for layer dxf group code instead of just 8, why is that ?

Just for aesthetics, so that the DXF codes are aligned  :ugly:

Another question, assuming you use VLIDE, what settings and where do i change to get the same formatting as your code ?

Yes, I use the VLIDE, but format code manually as I write it.

edit: i now compared the old code with yours and i find it strange that yours is slower although tightly written ?  :roll:

Yes, I may have sacrified some efficiency for concision with the mapcar expressions - why the eye roll?

XXL66

  • Newt
  • Posts: 99
Re: Unique xy point list but ignore z
« Reply #22 on: June 22, 2014, 10:49:02 AM »
hi, thx, just expected your code to be faster... because nice and tight

I don't use full HUE range because begin and end color would be almost the same and thus confusing. But later i want the range to be selectable, so you can choose your own sort of color swatch.
I don't think the problem has to do with light or saturation i would guess.
I will compare both and will try to print the differences.

But now i'm going to watch :mrgreen: (fFellaini) score against Russia.






Lee Mac

  • Seagull
  • Posts: 12905
  • London, England
Re: Unique xy point list but ignore z
« Reply #23 on: June 22, 2014, 10:58:45 AM »
But now i'm going to watch :mrgreen: (fFellaini) score against Russia.

Whatever the outcome, they're doing a lot better than England  :cry:


XXL66

  • Newt
  • Posts: 99
Re: Unique xy point list but ignore z
« Reply #24 on: June 23, 2014, 02:04:01 AM »
A lot better ? I almost fell asleep. All this euphory is almost embarrassing...