(defun LM:UniqueFuzzXY ( l f / x r )
(while l
(setq x (car l)
x_ (list (car x) (cadr x))
l (vl-remove-if (function (lambda ( y ) (equal x_ (list (car y) (cadr y)) f))) (cdr l))
r (cons x r)
)
)
(reverse r)
)
(defun butLast (l) (reverse (cdr (reverse l))))
^ yes, many of us (old ones or x-lispers) remember this place: http://autocad.xarch.at/news/faq/autolisp.html
Quote^ yes, many of us (old ones or x-lispers) remember this place: http://autocad.xarch.at/news/faq/autolisp.html
You must be my age, Luis.
ymg
with help from LM ! ty LM !
Not very important but...
The variable x_ is not localized in LM:UniqueFuzzXY.
I agree with you that BricsCAD is a very good product. But let's not forget the excellent Belgian beers... :laugh:Not very important but...
The variable x_ is not localized in LM:UniqueFuzzXY.
Very important (from your site):
... Arkey (a Dutch CAD program) and BricsCAD (After chocolates, the next best Belgian export product).
:wink:
BTW LM. I use another function from you that i use in a function to create a gradient color map on a tin (hsltorgb). The doslib version works fine, but yours gives me strange results...see attached picture.
Something seems to go wrong with the conversion.
Oops, really need to make an appointment with the ophthalmologist !
;*****************************************************************************;
; 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)
no, because i need the HLS, that is the input i get.
but no worries, the doslib version is fine.
;*****************************************************************************;
; 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)
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.
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).
(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
)
BTW: i see you use 008 for layer dxf group code instead of just 8, why is that ?
Another question, assuming you use VLIDE, what settings and where do i change to get the same formatting as your code ?
edit: i now compared the old code with yours and i find it strange that yours is slower although tightly written ? :roll:
But now i'm going to watch :mrgreen: (fFellaini) score against Russia.