"Pasteliser" des couleur RVB

[bonuscad]

Bonjour,

 

J'ai des aplats (beaucoup) auxquels sont affectés des couleurs RVB

Je voudrais que ces aplats aient une couleur plus pastel car actuellement leurs couleur est trop soutenue.

La procédure serait de garder la nuance mais d'augmenter la luminance (comme quand on est dans la palette en couleurs vraies en modèle TSL)

 

Comment faire cette modification en lisp sur un ensemble sélectionné; en fait comment calculer le RVB à fournir à (vla-put-TrueColor) pour influencer seulement la luminance.

 

A moins que quelqu'un connaisse une autre manière de faire pour aboutir à un résultat similaire?

[krunch]

Ce serait sans doute faisable en fabriquant les fonctions de conversion RVB>TSL et TSL>RVB décrites ici, mais il y a peut-être plus rapide.

[(gile)]

Salut,

 

Après quelques recherches et essais, j'ai fini par trouver des fonctions de conversions RGBHSL qui semble à peu près fonctionner ici (en tout cas qui retournent des résultats similaires (ou très proches) de ceux donnés par la boite de couleurs vraies d'AutoCAD).

 

D'après mes tests il peut y avoir quelques différences entre les données initiales et les valeurs retournées en faisant :

(apply 'hsl2rb (rgb2hsl r g B))

je pense que c'est dû aux arrondis des réels en entiers mais ça ne devrait pas avoir une grosse importance.

 

Les codes LISP :

 

(defun rgb2hsl (r g b / maxRgb minRgb d h s l)
 (setq	r      (/ r 255.)
g      (/ g 255.)
b      (/ b 255.)
maxRgb (max r g B)
minRgb (min r g B)
d      (- maxRgb minRgb)
h      (cond
	 ((zerop d) 0)
	 ((= maxRgb g) (fix (+ (* 60 (/ (- b r) d)) 120.5)))
	 ((= maxRgb B) (fix (+ (* 60 (/ (- r g) d)) 240.5)))
	 (T (rem (fix (+ (* 60 (/ (- g B) d)) 360.5)) 360))
       )
l      (fix (+ 0.5 (* (+ maxRgb minRgb) 50)))
s      (cond
	 ((zerop d) 0)
	 ((<= l 50) (fix (+ 0.5 (* 100 (/ d (+ maxRgb minRgb))))))
	 (T (fix (+ 0.5 (* 100 (/ d (- 2 maxRgb minRgb))))))
       )
 )
 (list h s l)
)

(defun hsl2rgb (h s l / q p hr hg hb)
 (setq h  (/ h 360.)
s  (/ s 100.)
l  (/ l 100.)
q  (if (< l 0.5)
     (* l (1+ s))
     (+ l s (- (* l s)))
   )
p  (- (* 2 l) q)
hr (rem (+ h (/ 1. 3)) 1.)
hg h
hb (rem (1+ (- h (/ 1. 3))) 1.)	
 )
 (mapcar
   '(lambda (x)
      (fix
 (+ 0.5
    (* 255
       (cond
	 ((< x (/ 1. 6)) (+ p (* (- q p) 6 x)))
	 ((< x 0.5) q)
	 ((< x (/ 2. 3)) (+ p (* (- q p) 6 (- (/ 2. 3) x))))
	 (p)
       )
    )
 )
      )
    )
   (list hr hg hb)
 )
)

[Julian-Nihon]

Bonjour,

 

Il y a aussi les sous fonction de conversion de couleur de Lee Mac

 

Ju du Japon

[bonuscad]

Merci de vos propositions, j'ai réussi à appliquer vos suggestions.

il peut y avoir quelques différences entre les données initiales et les valeurs retournées

 

En effet, mais cela est minime. Que ce soit avec ton code ou celui de Lee l'écart constaté est le même.

 

Je vais voir à fignoler l'application que j'ai écrite, car j'ai remarqué qu'à partir d'un patchwork assez multicolore, j'obtiens au final une nuance plus claire mais qui se regroupe sur 4 tons dominants (bleu clair, rouge marron clair, gris moyen et un blanc cassé).

On dirait un filtre appliqué à des photos satellites.

 

Je vais peut être transformer Autocad en PhotoShop... :D

[Tramber]

J'utilise depuis longtemps des fonctions de pastellisations telles que tu les demandes et que j'ai pu batir grâce à deux fonctions :

 

;;;HSL value should be integer
;;;The formular is obtained from the website of easyRGB
;;;The hsl is taken from Autocad H:[0,360],S:[0,100],L:[0,100]

(defun hsl2rgb (hsllist / h s l r g b var2 var1		func		)
 (defun func (v1 v2 vh / result)
   (if (< vh 0)      (setq vh (1+ vh))      )
   (if (> vh 1)      (setq vh (- vh 1))      )
   (cond
     ((< (* 6 vh) 1)       (setq result (+ v1 (* 6 vh (- v2 v1))))       )
     ((< (* 2 vh) 1)       (setq result v2)       )
     ((< vh 0.66667)       (setq result (+ v1 (* 6 (- v2 v1) (- 0.666667 vh))))       )
     (t       (setq result v1)       )      )    result    )
 
 (setq h (/ (nth 0 hsllist) 360.0)	s (/ (nth 1 hsllist) 100.0)	l (/ (nth 2 hsllist) 100.0)	)
 (cond
   ((= s 0)     (setq r (* l 255)	   g (* l 255)	   b (* l 255)	   )     )
   ((/= s 0)     (cond       ((< l 0.5)	(setq var2 (* l (1+ s)))	)
	    (t	(setq var2 (- (+ l s) (* s l)))	)       )
    (setq var1 (- (* 2 l) var2)
   r (* 255 (func var1 var2 (+ h 0.33333)))
   g (* 255 (func var1 var2 h))
   b (* 255 (func var1 var2 (- h 0.33333))))
    )
   )
 (list (fix r) (fix g) (fix B))
 )





; Author      :   jme
; Copyright   :   MENZI ENGINEERING GmbH, Switzerland
;;; by Menzi, for convert rgb value to hsl value
(defun MeCalcHslModel (Rgb / ColDta ColHue ColLum ColSat MaxVal	MinVal		       TmpRgb)
 (setq	TmpRgb (mapcar		 '/		 Rgb		 '(255.0 255.0 255.0)	       )
MaxVal (apply		 'max		 TmpRgb	       )	MinVal (apply		 'min		 TmpRgb	       )
ColDta (- MaxVal MinVal)
ColLum (/ (+ MaxVal MinVal) 2.0)
ColSat 0.0
ColHue 0.0
)
 (if (/= MaxVal MinVal)
   (setq ColSat (if (<= ColLum 0.5)
	   (/ ColDta (+ MaxVal MinVal))
	   (/ ColDta (- 2.0 MaxVal MinVal))		 )
  ColHue (cond
	   ((= (car TmpRgb) MaxVal)		    (/ (- (cadr TmpRgb) (caddr TmpRgb)) ColDta)		   )
	   ((= (cadr TmpRgb) MaxVal)		    (+ 2.0 (/ (- (caddr TmpRgb) (car TmpRgb)) ColDta))		   )
	   ((= (caddr TmpRgb) MaxVal)		    (+ 4.0 (/ (- (car TmpRgb) (cadr TmpRgb)) ColDta))		   )
	   )
  ColHue (* ColHue 60.0)
  ColHue (if (minusp ColHue)		   (+ ColHue 360.0)		   ColHue		 )
  )
   )
 (list	(if (> ColSat 0.0)	  (fix ColHue)	  nil	)	(fix (* ColSat 100.0))	(fix (* ColLum 100.0))	)
 )

 

Je réponds rapidement sans trop explorer les réponses.

Avec mon fils tout le temps malade, il faut dire que je suis complètement sous l'eau !

Au moment où j'écris, Monsieur réclame mes soins.... il n'y aura pas d'explications !

[bonuscad]

Merci Tramber,

 

Par curiosité et pour comparaison, j'ai testé aussi le code de Menzi.

Si j'ai pu l'appliquer sur quelques échantillons sans problème, sur l'ensemble il a avorté avec un : numberp nil

 

A priori le code est moins fiable que celui de Lee ou (gile), je n'ai pas recherché le bout de code qui pose problème...

 

Monsieur réclame mes soins.... il n'y aura pas d'explications !

 

On ne peut pas être au four et au moulin! ;)

[(gile)]

Salut,

 

Les routines que j'ai postée utilisent la même méthode que celles de Lee Mac (j'aurais dû me douter que ce prolixe LISPeur avait déjà fait quelque chose là dessus).

 

Pour ceux qui voudraient essayer, la commande LUM ci-dessous demande de sélectionner des objets (choisir plutôt des applats de couleurs différentes genre solide 2d ou hachures solid) puis demande de spécifier la luminosité (entier strictement entre 1 et 100) et change la luminosité des couleurs des objets tant que l'utilisateur entre une nouvelle valeur (on valide la dernière couleur avec Entrée, Echap, Espace ou clic droit).

Les routines rgb2hsl et hsl2rgb doivent bien sûr être chargées (j'ai un peu nettoyé ces routines écrites à la hâte hier soir).

 

(defun c:lum (/ acdoc ss lst)
 (if (ssget)
   (progn
     (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
     (vlax-for	obj (setq ss (vla-get-ActiveSelectionSet acdoc))
(setq lst (cons obj lst))
     )
     (vla-Delete ss)
     (vla-StartUndoMark acdoc)
     (vl-catch-all-apply
'(lambda (/ lum col hsl)
   (while (setq lum (getint "\nEntrez la luminosité: "))
     (if (< 0 lum 100)
       (foreach	obj lst
	 (setq col (vla-get-TrueColor obj))
	 (setq hsl (rgb2hsl (vla-get-Red col) (vla-get-Green col) (vla-get-Blue col)))
	 (apply 'vla-SetRgb (cons col (hsl2rgb (car hsl) (cadr hsl) lum)))
	 (vla-put-TrueColor obj col)
       )
       (princ "\nNécessite un entier de 1 à 99.")
     )
   )
 )
     )
     (vla-EndUndoMark acdoc)
   )
 )
 (princ)
)

 

la même chose pour jouer avec la saturation:

 

(defun c:sat (/ acdoc ss lst)
 (if (ssget)
   (progn
     (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
     (vlax-for	obj (setq ss (vla-get-ActiveSelectionSet acdoc))
(setq lst (cons obj lst))
     )
     (vla-Delete ss)
     (vla-StartUndoMark acdoc)
     (vl-catch-all-apply
'(lambda (/ sat col hsl)
   (while (setq sat (getint "\nEntrez la saturation: "))
     (if (< 0 sat 101)
       (foreach	obj lst
	 (setq col (vla-get-TrueColor obj))
	 (setq hsl (rgb2hsl (vla-get-Red col) (vla-get-Green col) (vla-get-Blue col)))
	 (apply 'vla-SetRgb (cons col (hsl2rgb (car hsl) sat (caddr hsl))))
	 (vla-put-TrueColor obj col)
       )
       (princ "\nNécessite un entier de 1 et 100.")
     )
   )
 )
     )
     (vla-EndUndoMark acdoc)
   )
 )
 (princ)
)

[bonuscad]

Un grand merci (gile), cela fonctionne parfaitement.

Je conserve bien mes teintes, au contraire de ce que j'avais pu coder...

 

j'ai juste rajouté:

 

(vlax-put-property obj 'PatternFillTrueColor col)

 

pour pouvoir l'appliquer au remplissage des MPOLYGON de Map.

 

D'ailleurs je ne comprends pas pourquoi je ne peux pas faire un:

(vla-put-PatternFillTrueColor obj col)

[lecrabe]

Hello Bruno

 

SVP tu as rajoute cette ligne ou physiquement dans le programme de Gilles ?

 

Merci d'avance pour mes MPOLYGONs ... et MERCI a Gilles ...

 

Bye, lecrabe

[bonuscad]

SVP tu as rajoute cette ligne ou physiquement dans le programme de Gilles ?

 

Tout simplement après la ligne (vla-put-TrueColor obj col) inclu dans la boucle (foreach, ceci dans les deux fonction (c:SAT et c:LUM)

 

Autrement si tu est intéressé aussi par la mise en place rapide d'un "patchwork" de MPOLYGON, j'utilise ceci:

NB: les sous-fonctions de sont pas de moi (je suis incapable de citer l'auteur, navré pour lui)

 

(defun ACI2RGB (n / l1 l3)
 (cond
   ( (or(> n 255)(< n 1))nil)
   ( (> 7 n 0)(aci2rgb(+ 10(* 40(1- n)))))
   ( (> 250 n 9)
     (setq l1
      '(0 1 2 3 4 4 4 4 4 4 4 4 4 3 2 1 0 0 0 0 0 0 0 0)
     )
     (setq l3 '(1 0.8 0.6 0.5 0.3))
     (mapcar
      '(lambda(v w / )
         (fix
           (* 255
             (+
               (*
                 0.25
                 (nth(rem(+(1-(/ n 10))v)24)l1)
                 (nth(/(rem n 10)2)l3)
               )
               (*
                 (rem n 2)
                 0.125
                 (nth(rem(+(1-(/ n 10))w)24)l1)
                 (nth(/(rem n 10)2)l3)
               )
             )
           )
         )
       )
      '(8 0 16)
      '(20 12 4)
     )
   )
   (1
     (apply
      '(lambda(v w / )(list w w w))
       (assoc n
         '((7 255)(8 128)(9 192)(250 51)(251 91)(252 132)
                            (253 173)(254 214)(255 255)))
     )
   )
 )
)
(defun randnum (/ modulus multiplier increment random);retourne valeur entre 0 et 1
 (if (not seed)
   (setq seed (getvar "DATE"))
 )
 (setq modulus    65536
       multiplier 25173
       increment  13849
       seed (rem (+ (* multiplier seed) increment) modulus)
       random (/ seed modulus)
 )
)
(defun getrandnum (minNum maxNum / tmp);fourchette du nombre aleatoire
 (if (not (< minNum maxNum))
   (progn
     (setq tmp    minNum
           minNum maxNum
           maxNum tmp
     )
   )
 )
 (setq random (+ (* (randnum) (- maxNum minNum)) minNum))
)
(defun c:randnum_color_mpolygon ( / js n obj ncol oColor RGBcolor)
 (setq js (ssget '((0 . "MPOLYGON"))))
 (cond
   (js
     (repeat (setq n (sslength js))
       (setq obj (vlax-ename->vla-object (ssname js (setq n (1- n)))))
       (while (not (eq (rem (setq ncol (fix (getrandnum 11 241))) 10) 1)))
       (setq
         oColor (vlax-get-property obj 'TrueColor)
         RGBcolor (ACI2RGB ncol)
       )
       (vlax-invoke-method oColor 'SetRGB (car RGBcolor) (cadr RGBcolor) (caddr RGBcolor))
       (vla-put-TrueColor obj oColor)
       (vlax-put-property obj 'PatternFillTrueColor oColor)
     )
   )
 )
 (prin1)
)