;;;
;;; Minimum US/English translation by Patrice
;;;

;;;
;;; Nouvelle version de la routine CORRIDOR
;;; CORRIDOR2.LSP le 09/07/2007
;;; Taper au clavier: CORRIDORVERYNEW
;;;
;;; ATTENTION: Pour ACAD/MAP 2007/2008/2009
;;; Ne fonctionne pas sur versions precedentes
;;;
;;; Routine : CORRIDORVERYNEW from Gilles (gile)
;;;

(defun c:cr (/ *error* JoinPlines HatchPline AcDoc
Space sort inc ht ss extr col long
larg pl0 nor pl1 pl2 ps1 ps2 nb
n pt0 pa0 pt1 pt2 cut1 cut2 txt
box
)

(vl-load-com)

;; Redיfintion de *error* (fermeture du groupe d'annulation)
(defun *error* (msg)
(if (= msg "Fonction annulיe")
(princ)
(princ (strcat "\nErreur: " msg))
)
(vla-endundomark
(vla-get-activedocument (vlax-get-acad-object))
)
(princ)
)

;; Joint deux polylignes en une polyligne fermיe
(defun JoinPlines (p1 p2 / v1 v2 i lst pl)
(setq v1 (fix (vlax-curve-getEndParam p1))
v2 (fix (vlax-curve-getEndParam p2))
i 0
)
(repeat v1
(setq lst (cons (cons i (vla-getBulge p1 i)) lst)
i (1+ i)
)
)
(setq i (1+ i))
(repeat v2
(setq lst (cons (cons i (- (vla-GetBulge p2 (setq v2 (1- v2))))) lst)
i (1+ i)
)
)
(setq pl
(vlax-invoke
Space
'addLightWeightPolyline
(append (vlax-get p1 'Coordinates)
(apply 'append
(reverse (split-list (vlax-get p2 'Coordinates) 2))
)
)
)
)
(vla-put-Closed pl :vlax-true)
(mapcar '(lambda (x) (vla-SetBulge pl (car x) (cdr x))) lst)
(vla-put-Normal pl (vla-get-Normal p1))
(vla-put-Elevation pl (vla-get-Elevation p1))
(vla-delete p1)
(vla-delete p2)
pl
)

;; hachure une polyligne (SOLID)
(defun HatchPline (pl / hatch)
(setq hatch (vla-AddHatch
Space
acHatchPatternTypePredefined
"SOLID"
:vlax-true
)
)
(vlax-invoke hatch 'AppendOuterLoop (list pl))
(vla-put-Color hatch col)
(vlax-invoke sort 'MoveToBottom (list hatch))
)

;; Fonction principale
(setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
Space (if (= (getvar "CVPORT") 1)
(vla-get-PaperSpace AcDoc)
(vla-get-ModelSpace AcDoc)
)
)
(or (vlax-ldata-get "corridor" "long")
(vlax-ldata-put "corridor" "long" 40.0)
)
(or (vlax-ldata-get "corridor" "larg")
(vlax-ldata-put "corridor" "larg" 20.0)
)
(or (vlax-ldata-get "corridor" "num")
(vlax-ldata-put "corridor" "num" 1)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (initget "Oui Non")
(initget "Yes No")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(if

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (/= "Non"
; (getkword "\Numיroter les boites ? [Oui/Non] : ")
(/= "No"
(getkword "\Numbering Boxes ? [Yes/No] : ")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

)
(progn
(if (setq inc

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (getint (strcat "\nEntrez le numיro de dיpart <"
(getint (strcat "\nEnter First Number : "
)
)
)
(vlax-ldata-put "corridor" "num" inc)
(setq inc (vlax-ldata-get "corridor" "num"))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (if (setq ht (getdist (strcat "\nSpיcifiez la hauteur de texte <"
(if (setq ht (getdist (strcat "\nSpecify Text Height : "
)
)
)
(setvar "TEXTSIZE" ht)
(setq ht (getvar "TEXTSIZE"))
)
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (initget "Oui Non")
(initget "Yes No" )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (setq extr (getkword "\nBoites aux extrיmitיs seulement ? [Oui/Non] : "))
(setq extr (getkword "\nBoxes at the End only ? [Yes/No] : "))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(initget 6)
(if (setq larg

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (getdist (strcat "\nLargeur/Emprise des boites <"
(getdist (strcat "\nBoxes Width : "
)
)
)
(vlax-ldata-put "corridor" "larg" larg)
(setq larg (vlax-ldata-get "corridor" "larg"))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (if (= "Non" extr)
(if (= "No" extr)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(progn
(initget 6)
(if (setq long

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (getdist (strcat "\nLongueur des boites (3 4)
;;; (sublst '(1 2 3 4 5 6) 3 -1) -> (3 4 5 6)
;;; (sublst '(1 2 3 4 5 6) 3 12) -> (3 4 5 6)
;;; (sublst '(1 2 3 4 5 6) 3 nil) -> (3 4 5 6)

(defun sublst (lst start leng / rslt)
(or ( ((1 2) (3 4) (5 6) (7 8))
;; (split-list '(1 2 3 4 5 6 7 8) 3) -> ((1 2 3) (4 5 6) (7 8))

(defun split-list (lst n)
(if lst
(cons (sublst lst 1 n)
(split-list (sublst lst (1+ n) nil) n)
)
)
)

;;; CutPlineAtPoint
;;; Coupe la polyligne au point spיcifiי et retourne la liste des deux objets gיnיrיs
;;; (ename ou vla-object selon le type de l'argument pl)
;;;
;;; Arguments
;;; pl : la polyligne א couper (ename ou vla-object)
;;; pt : le point de coupure sur la polyligne (coordonnיes SCG)

(defun CutPlineAtPoint
(pl pt / en no pa p0 p1 pn cl l0 l1 l2 ce sp c b0 b1 b2
bp a1 a2 n wp w0 w1 w2)
(vl-load-com)
(or (= (type pl) 'VLA-OBJECT)
(setq pl (vlax-ename->vla-object pl)
en T
)
)
(setq no (vlax-get pl 'Normal)
pa (fix (vlax-curve-getParamAtPoint pl pt))
p0 (vlax-curve-getPointAtparam pl pa)
p1 (vlax-curve-getPointAtParam pl (1+ pa))
pn (reverse (cdr (reverse (trans pt 0 no))))
cl (vla-Copy pl)
l0 (vlax-get pl 'Coordinates)
l1 (append (sublst l0 1 (* 2 (1+ pa))) pn)
l2 (append pn (sublst l0 (1+ (* 2 (1+ pa))) nil))
ce (if (not (equal pt p0 1e-9))
(ArcCenterBy3Points (trans p0 0 no) pn (trans p1 0 no))
)
sp (reverse
(cdr (reverse (trans (vlax-curve-getStartPoint pl) 0 no)))
)
)
(and (= (vla-get-Closed pl) :vlax-true)
(setq c T
l2 (append l2 sp)
)
)
(repeat (setq n (if c
(fix (vlax-curve-getendParam pl))
(fix (1+ (vlax-curve-getendParam pl)))
)
)
(setq b0 (cons (vla-getBulge pl (setq n (1- n))) b0))
(vla-GetWidth pl n 'StartWidth 'EndWidth)
(setq w0 (cons (list StartWidth EndWidth) w0))
)
(setq bp (nth pa b0))
(if ce
(progn
(setq a1 (- (angle ce pn) (angle ce (trans p0 0 no)))
a2 (- (angle ce (trans p1 0 no)) (angle ce pn))
)
(if (minusp bp)
(foreach a '(a1 a2)
(if (ename pl)
)
(list pl cl)
)
)

(princ "\nTape to Invoke : CR \n")
(c:cr)