;Parametric Vocabulary: perg_rect_beam.lsp
;Autolisp file for 4.207 prepared by Lee, Hee Won
;Date: 12/1/96
;This file draws 3 dimensional  pergola.
;Use of functions defined in this file
;(perg_rect_beam x y z sw sd h rh1 s_nrow s_gap_row s_gap_col
;		   cw ct cwr ctr c_cant) 
;(demo1)

;(defun c:r () (load "w_column"))
;(xload "geom3d")


(command "units" 4 "" "" "" "" "")
(command "limits" (list -1200  -1200) (list 1200 1200))
(command "vpoint" (list -1 -1 1))
;(load "nagakura")
;(command "cmdecho" "0")
;(load "perg_rect_shaft.lsp")
(defun perg_rect_shaft (x y z w d h nrow gap_row gap_col)    
     ;Set up local coordinate system
     (command "ucs" "origin" (list 0 0 z))

     ;This is setting up a new layer.
     (command "layer" "new" "rect_shaft1" "color" "white" "rect_shaft1" "")
   
     ;Draw 3d_shaft on layer "rect_shaft1"
     (command "layer" "set" "rect_shaft1" "")

     ;Draw 2d_shaft                       
     (command "pline" (list (- x (* 0.5 w)) (- y (* 0.5 d)))
	      (list (+ x (* 0.5 w)) (- y (* 0.5 d)))
	      (list (+ x (* 0.5 w)) (+ y (* 0.5 d)))
	      (list (- x (* 0.5 w)) (+ y (* 0.5 d)))  "c" )  
     (setq ent1 (entlast))

     ;Draw 3d_shaft
     (command "extrude" ent1 "" (list 0 0) (list 0 0 h) "" )
     (setq ent (entlast))

     ;Varible 'elist' gets the result of 'tarry' function
     (setq elist (tarray ent nrow 2  gap_row gap_col))
     
     ;Create axonometric view.
     ;(command "vpoint" (list -1 -1 1) )
   
     ;Reset the ucs to world-coordinate-system
     (command "ucs" "world")
 
     ;Make 'elist' as a block for "nagakura" program   
     (nt_make_ablock elist)
 
)    ; end of defun
 
     ;Define a type with its symbolic contents and shape specification
     (nt_def_type "perg_rect_shaft" 'perg_rect_shaft
		  '(("xo" . 0) ("yo" . 0) ("zo" . 0) ("w" . 12) 
		    ("d" . 12) ("h" . 180) ("nrow" . 7)
		    ("gap_row" . 120) ("gap_col" . 120)))

;(load "perg_round_shaft")
(defun perg_round_shaft (x y z r h nrow gap_row gap_col)    
     ; Set up local coordinate system
     (command "ucs" "origin" (list 0 0 z) )

     ;This is setting up a new layer.
     (command "layer" "new" "round_shaft1" "color" "white" "round_shaft1" "")
   
     ; Set layer "round_shaft1"
     (command "layer" "set" "round_shaft1" "")

     ; Draw 2d_shaft  
     (command "circle" (list x y) r)
     (setq ent1 (entlast))
     
     ;Copy to a specified height
     (command "copy" ent1 "" (list x y z)  (list x y (+ z h)))
     (setq ent2(entlast))

     ;Set the number of tabulations
     (command "surftb1" "12")

     ;Create 3d_shaft
     (command "rulesurf" ent1 ent2)
     (setq ent3(entlast))
     (command "erase" ent1 "")
     (command "erase" ent2 "")

     ;Varible 'elist' gets the result of 'rarry' function
     (setq elist (rarray ent3 r  nrow 2  gap_row gap_col))
     
     ;Create axonometric view.
     ;(command "vpoint" (list -1 -1 1) )
   
     ;Reset the ucs to world-coordinate-system
     (command "ucs" "world")
 
     ;Make 'elist' as a block for "nagakura" program
     (nt_make_ablock elist)
)    ; end of defun

     ;Define a type with its symbolic contents and shape specification
     (nt_def_type "perg_round_shaft" 'perg_round_shaft
		  '(("xo" . 0) ("yo" . 0) ("zo" . 0) ("r" . 12) 
		    ("h" . 180) ("nrow" . 7) 
		    ("gap_row" . 120) ("gap_col" . 120)))

;(load "perg_capital_beam")
(defun perg_capital_beam (x y z w t wr tr cant nrow  gap_row gap_col)
     ;Set up local coordinate system
     (command "ucs" "origin" (list 0 0 z))

     ;This is setting up a new layer.
     (command "layer" "new" "perg_1" "color" "white" "perg_1" "")

     ;Draw 3d_base on layer "perg_1"
     (command "layer" "set" "perg_1" "")

     ;Draw long 2d_beam                       
     (command "pline" (list (- x (* 0.5 w)) (- y (* 0.5 w)))
	      (list (+ x (* 0.5 w)) (- y (* 0.5 w)))
	      (list (+ x (* 0.5 w)) (+ y (+ (* (- nrow 1) gap_row) (* 0.5 w))))
	      (list (- x (* 0.5 w)) (+ y (+ (* (- nrow 1) gap_row) (* 0.5 w))))
	      "c" )  
     (setq ent(entlast))

     ;Draw long 3d_beam
     (command "extrude" ent "" (list 0 0) (list 0 0 t) "")
     (setq ent1(entlast))

     (command "copy" ent1  "" (list x y z)  (list (+ x gap_col) y z))
     (setq ent2(entlast))

     ;Draw short 2d_beam
     (command "pline" (list (- x cant) (- y (* (* 0.5 wr) w))) 
	      (list (+ (+ x gap_col)  cant) (- y (* (* 0.5 wr) w)))
	      (list (+ (+ x gap_col)  cant) (+ y (* (* 0.5 wr) w)))
	      (list (- x cant) (+ y (* (* 0.5 wr) w)))
	      "c" )  
     (setq ent3(entlast))
     
     ;Draw short 3d_beam
     (command "extrude" ent3 "" (list 0 0) (list 0 0 (* t tr)) "")
     (setq ent4(entlast))

     (command "move" ent4 "" (list x y z)  (list x y (+ z t)))
     (setq ent5(entlast))
     
     ;Variable 'elist' gets the result of 'beam_array' function
     (setq elist (beam_array ent5 nrow 1  gap_row gap_col))

     (setq flist (append elist (list ent1 ent2)))

     ;Create axonometric view.
     ;(command "vpoint" (list -1 -1 1) )
   
     ;Reset the ucs to world-coordinate-system
     (command "ucs" "world")

     ;Make 'elist' as a block for "nagakura" program   
     (nt_make_ablock flist)
)    ;end of defun

;Define a type with its symbolic contents and shape specification
(nt_def_type "perg_capital_beam" 'perg_capital_beam
	  '(("xo" . 0) ("yo" . 0) ("zo" . 0) ("w" . 3) ("t" . 12)
	    ("wr" . 1) ("tr" . 1.5) ("cant" . 6)
	    ("nrow" . 21) ("gap_row" . 30) ("gap_col" . 120)))

;(load "perg_capital_frame")
(defun perg_capital_frame (x y z w gap_h nrow gap_row gap_col)
     ;Set up local coordinate system
     (command "ucs" "origin" (list 0 0 z))

     ;This is setting up a new layer.
     (command "layer" "new" "perg_2" "color" "white" "perg_2" "")

     ;Draw 3d_base on layer "perg_2"
     (command "layer" "set" "perg_2" "")

     ;Draw long 2d_beam                       
     (command "pline" (list (- x (* 0.5 w)) (- y (* 0.5 w)))
	      (list (+ x (* 0.5 w)) (- y (* 0.5 w)))
	      (list (+ x (* 0.5 w)) (+ y (+ (* (- nrow 1) gap_row) (* 0.5 w))))
	      (list (- x (* 0.5 w)) (+ y (+ (* (- nrow 1) gap_row) (* 0.5 w))))
	      "c" )  
     (setq ent(entlast))

     ;Draw long 3d_beam
     (command "extrude" ent "" (list 0 0) (list 0 0 w) "")
     (setq ent1(entlast))

     (command "copy" ent1 "" (list x y z)  (list x y (+ z (+ w gap_h))))
     (setq ent2(entlast))

     (command "copy" ent1  "" (list x y z)  (list (+ x gap_col) y z))
     (setq ent3(entlast))

     (command "copy" ent3 "" (list x y z)  (list x y (+ z (+ w gap_h))))
     (setq ent4(entlast))

     ;Draw 2d_beam                       
     (command "pline" (list (- x (* 0.5 w)) (- y (* 0.5 w))) 
	      (list (+ x (* 0.5 w)) (- y (* 0.5 w)))
	      (list (+ x (* 0.5 w)) (+ y (* 0.5 w)))
	      (list (- x (* 0.5 w)) (+ y (* 0.5 w)))
	      "c" )  
     (setq ent5(entlast))

     ;Draw 3d_beam
     (command "extrude" ent5 "" (list 0 0) (list 0 0 gap_h) "")
     (setq ent6(entlast))

     (command "move" ent6 "" (list x y z)  (list x y (+ w z)))
     (setq ent7(entlast))

     (command "copy" ent7 "" (list x y z)  (list (+ x gap_col) y z)) 
     (setq ent8(entlast))

     (command "pline" (list (- x (* 0.5 w)) (- y (* 0.5 w))) 
	      (list (+ x (- gap_col (* 1.5 w))) (- y (* 0.5 w)))
	      (list (+ x (- gap_col (* 1.5 w))) (+ y (* 0.5 w)))
	      (list (- x (* 0.5 w)) (+ y (* 0.5 w)))
	      "c" )  
     (setq ent9(entlast))
     
     (command "extrude" ent9 "" (list 0 0) (list 0 0 w) "")
     (setq ent10(entlast))

     (command "move" ent10 "" (list x y z)  (list (+ x w) y z))
     (setq ent11(entlast))

     (command "copy" ent11 "" (list x y z)  (list x y (+ z (+ w gap_h)))) 
     (setq ent12(entlast)) 

     ;Variable 'elist' gets the result of 'beam_array' function
     (setq elist (beam_array (list ent7 ent8 ent11 ent12)  
			     nrow 1 gap_row gap_col))

     (setq flist (append  elist (list ent1 ent2 ent3 ent4)))

     ;Create axonometric view.
     ;(command "vpoint" (list -1 -1 1) )
   
     ;Reset the ucs to world-coordinate-system
     (command "ucs" "world")

     ;Make 'elist' as a block for "nagakura" program   
     (nt_make_ablock flist)
)    ;end of defun

;Define a type with its symbolic contents and shape specification
(nt_def_type "perg_capital_frame" 'perg_capital_frame
       '(("xo" . 0) ("yo" . 0) ("zo" . 0) ("w" . 3) ("gap_h" . 24)
	  ("nrow" . 21) ("gap_row" . 30) ("gap_col" . 120)))

;(load "beam_array")
(defun beam_array_sub (ent  nrow ncol gap_row gap_col
		   / M N result_list new_ent)
  (setq result_list (list ent))
  (setq M 0)
  (setq nrow (fix nrow))
  (setq ncol (fix ncol))
  (repeat nrow
	  (progn
	    (setq N 0)
	    (repeat ncol 
                   (command "copy"
                            ent "" (list 0 0 0) 
			     (list (* N gap_col)
				   (* M gap_row) 0))
		    (setq new_ent (entlast))
		    (if (and (= N 0) (= M 0))
			(command "erase" new_ent "")
		      (setq result_list (cons new_ent result_list)) 
		      ) 		    
		    (setq N (+ N 1))
		    ) ;end repeat ncol 
	    ) ;end progn
	  (setq M (+ M 1))
	  ) ; end repeat nrow
  result_list
  )

(defun beam_array (ent_list nrow ncol gap_row gap_col / result sub_list)

   (if (null (listp ent_list))
      (setq ent_list (list ent_list)))


   (while ent_list
     (setq sub_list (beam_array_sub (car ent_list)  nrow ncol gap_row gap_col))
;  (print sub_list)
;  (print ent_list)
     (setq result (append sub_list result))
     (setq ent_list (cdr ent_list))
   )
 result
)

;(load "rarray")
(defun rarray (ent r nrow ncol gap_row gap_col
		   / M N result_list new_ent)
  (setq result_list (list ent))
  (setq M 0)
  (setq nrow (fix nrow))
  (setq ncol (fix ncol))
  (repeat nrow
	  (progn
	    (setq N 0)
	    (repeat ncol 
		    (command "copy" ent "" (list 0 0 0) 
			     (list (* N  gap_col)
				   (* M  gap_row) 0))
		    (setq new_ent (entlast))
		    (if (and (= N 0) (= M 0))
			(command "erase" new_ent "")
		      (setq result_list (cons new_ent result_list)) 
		      ) 		    
		    (setq N (+ N 1))
		    ) ;end repeat ncol 
	    ) ;end progn
	  (setq M (+ M 1))
	  ) ; end repeat nrow
  result_list
  )
;(load "tarray")
(defun tarray (ent nrow ncol gap_row gap_col
		   / M N result_list new_ent)
  (setq result_list (list ent))
  (setq M 0)
  (setq nrow (fix nrow))
  (setq ncol (fix ncol))
  (repeat nrow
	  (progn
	    (setq N 0)
	    (repeat ncol 
		    (command "copy" ent "" (list 0 0 0) 
			     (list (* N   gap_col)
				   (* M   gap_row) 0))
		    (setq new_ent (entlast))
		    (if (and (= N 0) (= M 0))
			(command "erase" new_ent "")
		      (setq result_list (cons new_ent result_list)) 
		      ) 		    
		    (setq N (+ N 1))
		    ) ;end repeat ncol 
	    ) ;end progn
	  (setq M (+ M 1))
	  ) ; end repeat nrow
  result_list
  )

;(defun perg_rect_beam (xo yo zo sw sd ph rh1 s_nrow s_gap_row 
;    s_gap_col cw ct cwr ctr c_cant)    

;  (perg_rect_shaft xo yo zo sw sd (* ph rh1) s_nrow 
;		    s_gap_row s_gap_col)
;  (perg_capital_beam xo yo (+ zo (* ph rh1)) cw  ct cwr 
;		     ctr c_cant (+ 1 (* s_nrow 4)) 
;		     (* s_gap_row 0.4) s_gap_col)
;);end of defun

;  (nt_def_type "perg_rect_beam" 'perg_rect_beam
;	       '(("xo" . 0) ("yo" . 0) ("zo" . 0) ("sw" . 12)("sd" . 12) 
;		 ("ph" . 180) ("rh1" . 0.75) ("s_nrow" . 6) 
;		 ("s_gap_row" . 120) ("s_gap_col" . 120)
;		 ("cw" . 3) ("ct" . 12) ("cwr" . 1)
;		 ("ctr" . 1.5) ("c_cant" . 6) 
;		 ))

;(defun perg_rect_beam (xo yo zo sw sd ph rh1 s_nrow  s_gap_row 
;           s_gap_col cw ct cwr ctr c_cant  
;	   / c1 c2 shaft_c_plist capital_c_plist)
;  (setq shaft_c_plist
;	(list (cons "xo" xo)
;	      (cons "yo" yo)
;	      (cons "zo" zo)
;	      (cons "w" sw)
;	      (cons "d" sd)
;	      (cons "h" (* ph rh1))
;	      (cons "nrow" s_nrow)	   
;	      (cons "gap_row" s_gap_row)
;	      (cons "gap_col" s_gap_col)
;	      ))

;  (setq capital_c_plist
;	(list (cons "xo" xo)
;	      (cons "yo" yo)
;	      (cons "zo" (+ zo (* rh1 ph)))
;	      (cons "w" cw)
;      	      (cons "t" ct)
;	      (cons "wr" cwr)
;	      (cons "tr" ctr)
;	      (cons "cant" c_cant)
;	      (cons "nrow" (+ 1 (/ (* (- s_nrow 1) s_gap_row) 
;			       (/ s_gap_row 4))))
;	      (cons "gap_row" (/ s_gap_row 4))
;	      (cons "gap_col" s_gap_col)
;	      ))

;  (setq c1 (list "perg_rect_shaft" nil shaft_c_plist))
;  (setq c2 (list "perg_capital_beam" nil capital_c_plist))
;  (nt_composit (list c1 c2))
;)

(nt_def_trans '("perg_capital_beam") "perg_capital_frame" 'perg_beam2frame
	      nil 'replace)

(nt_def_trans '("perg_capital_frame") "perg_capital_beam" 'perg_frame2beam
	      nil 'replace)

(defun perg_beam2frame (beam_list trans_plist /
		     beam c_plist f_plist beam_plist)
  (setq beam (car beam_list))
  (setq beam_plist (nt_plist beam))
  (setq c_plist (list (cons "xo" (nt_val "xo" beam_plist))
		      (cons "yo" (nt_val "yo" beam_plist))
		      (cons "zo" (nt_val "zo" beam_plist))
		      (cons "w" (nt_val "w" beam_plist))		  
		      (cons "gap_h" (* (nt_val "t" beam_plist) 2))
		      (cons "nrow" (nt_val "nrow" beam_plist))
		      (cons "gap_row" (nt_val "gap_row" beam_plist))
		      (cons "gap_col" (nt_val "gap_col" beam_plist))
		      ))
  (setq f_plist nil)
  (list f_plist c_plist)
)

(defun perg_frame2beam (frame_list trans_plist /
		     frame c_plist f_plist frame_plist)
  (setq frame (car frame_list))
  (setq frame_plist (nt_plist frame))
  (setq c_plist (list (cons "xo" (nt_val "xo" frame_plist))
		      (cons "yo" (nt_val "yo" frame_plist))
		      (cons "zo" (nt_val "zo" frame_plist))
		      (cons "w" (nt_val "w" frame_plist))	      	     
		      (cons "nrow" (nt_val "nrow" frame_plist))
		      (cons "gap_row" (nt_val "gap_row" frame_plist))
		      (cons "gap_col" (nt_val "gap_col" frame_plist))
		      (cons "t"  (/ (nt_val "gap_h" frame_plist) 1.75))
		      ))
  (setq f_plist (list 
		      (cons "wr" 1)
		      (cons "tr" 1.5)
		      (cons "cant" 6)
		      ))
  (list f_plist c_plist)
)



(nt_def_trans '("perg_rect_shaft") "perg_round_shaft" 'perg_rect2round
	      nil 'replace)
(nt_def_trans '("perg_round_shaft") "perg_rect_shaft" 'perg_round2rect
	      nil 'replace)


(defun perg_rect2round (rect_list trans_plist /
		     rect c_plist f_plist rect_plist)
  (setq rect (car rect_list))
  (setq rect_plist (nt_plist rect))
  (setq c_plist (list (cons "xo" (nt_val "xo" rect_plist))
		      (cons "yo" (nt_val "yo" rect_plist))
		      (cons "zo" (nt_val "zo" rect_plist))
		      (cons "r" (* (nt_val "w" rect_plist) 0.75))
		      (cons "h" (nt_val "h" rect_plist))
		      (cons "nrow" (nt_val "nrow" rect_plist))
		      (cons "gap_row" (nt_val "gap_row" rect_plist))
		      (cons "gap_col" (nt_val "gap_col" rect_plist))
		      ))
  (setq f_plist nil)
  (list f_plist c_plist)
)

(defun perg_round2rect (round_list trans_plist /
		     round c_plist f_plist round_plist)
  (setq round (car round_list))
  (setq round_plist (nt_plist round))
  (setq c_plist (list (cons "xo" (nt_val "xo" round_plist))
		      (cons "yo" (nt_val "yo" round_plist))
		      (cons "zo" (nt_val "zo" round_plist))
		      (cons "w" (* (nt_val "r" round_plist) 1.5))
		      (cons "d" (* (nt_val "r" round_plist) 1.5))
		      (cons "h" (nt_val "h" round_plist))
		      (cons "nrow" (nt_val "nrow" round_plist))
		      (cons "gap_row" (nt_val "gap_row" round_plist))
		      (cons "gap_col" (nt_val "gap_col" round_plist))
		      ))
  (setq f_plist nil)
  (list f_plist c_plist)
)


(defun rect_box (x y z w d h)    
     ;Set up local coordinate system
     (command "ucs" "origin" (list 0 0 z) )

     ;This is setting up a new layer.
     (command "layer" "new" "rect_shaft1" "color" "white" "rect_shaft1" "")
   
     ;Draw 3d_shaft on layer "rect_shaft1"
     (command "layer" "set" "rect_shaft1" "")

     ;Draw 2d_shaft                       
     (command "pline" (list (- x (* 0.5 w)) (- y (* 0.5 w)))
	      (list (+ x (* 0.5 w)) (- y (* 0.5 w)))
	      (list (+ x (* 0.5 w)) (+ y (- d (* 0.5 w))))
	      (list (- x (* 0.5 w)) (+ y (- d (* 0.5 w))))
	      "c" )  
     (setq ent1 (entlast))

     ;Draw 3d_shaft
     (command "extrude" ent1 "" (list 0 0) (list 0 0 h) "" )
     (setq ent(entlast))

     ;Reset the ucs to world-coordinate-system
     (command "ucs" "world")
 
     ;Make 'ent' as a block for "nagakura" program   
     ;(nt_make_ablock ent)
     ent
)    ; end of defun
 
     ;Define a type with its symbolic contents and shape specification
     (nt_def_type "rect_box" 'rect_box
		  '(("xo" . 0) ("yo" . 0) ("zo" . 0) ("w" . 120) 
		    ("d" . 600) ("h" . 180)))


(defun perg_box1 (x y z w nrow gap_row  h)    
     ;Set up local coordinate system
     (command "ucs" "origin" (list 0 0 z) )

     ;This is setting up a new layer.
     (command "layer" "new" "rect_shaft1" "color" "white" "rect_shaft1" "")
   
     ;Draw 3d_shaft on layer "rect_shaft1"
     (command "layer" "set" "rect_shaft1" "")

     ;Draw 2d_shaft                       
     (command "pline" (list (- x (* 0.5 w)) (- y (* 0.5 w)))
	      (list (+ x (* 0.5 w)) (- y (* 0.5 w)))
	      (list (+ x (* 0.5 w)) (+ y (- (* nrow gap_row) (* 0.5 w))))
	      (list (- x (* 0.5 w)) (+ y (- (* nrow gap_row) (* 0.5 w))))
	      "c" )  
     (setq ent1 (entlast))

     ;Draw 3d_shaft
     (command "extrude" ent1 "" (list 0 0) (list 0 0 h) "" )
     (setq ent(entlast))

     ;Reset the ucs to world-coordinate-system
     (command "ucs" "world")
 
     ;Make 'ent' as a block for "nagakura" program   
     ;(nt_make_ablock ent)
     ent
)    ; end of defun
 
     ;Define a type with its symbolic contents and shape specification
     (nt_def_type "perg_box1" 'perg_box1
		  '(("xo" . 0) ("yo" . 0) ("zo" . 0) ("w" . 120) 
		    ("nrow" . 5) ("gap_row" . 120) ("h" . 144)))

(defun perg_box2 (x y z w t_nrow t_gap_row  h)    
     ;Set up local coordinate system
     (command "ucs" "origin" (list 0 0 z) )

     ;This is setting up a new layer.
     (command "layer" "new" "rect_shaft1" "color" "white" "rect_shaft1" "")
   
     ;Draw 3d_shaft on layer "rect_shaft1"
     (command "layer" "set" "rect_shaft1" "")

     ;Draw 2d_shaft                       
     (command "pline" (list (- x (* 0.5 w)) (- y (* 0.5 w)))
	      (list (+ x (* 0.5 w)) (- y (* 0.5 w)))
	      (list (+ x (* 0.5 w)) (+ y (- (* t_nrow t_gap_row) (* 0.5 w))))
	      (list (- x (* 0.5 w)) (+ y (- (* t_nrow t_gap_row) (* 0.5 w))))
	      "c" )  
     (setq ent1 (entlast))

     ;Draw 3d_shaft
     (command "extrude" ent1 "" (list 0 0) (list 0 0 h) "" )
     (setq ent(entlast))

     ;Reset the ucs to world-coordinate-system
     (command "ucs" "world")
 
     ;Make 'ent' as a block for "nagakura" program   
     ;(nt_make_ablock ent)
     ent
)    ; end of defun
 
     ;Define a type with its symbolic contents and shape specification
     (nt_def_type "perg_box2" 'perg_box2
		  '(("xo" . 0) ("yo" . 0) ("zo" . 0) ("w" . 120) 
		    ("t_nrow" . 5) ("t_gap_row" . 120) ("h" . 36)))


(defun perg_box (xo yo zo w nrow gap_row  h rh )    

  (perg_box1 xo yo zo w (* nrow gap_row) (* h rh))
  (perg_box2 xo yo (+ (+ zo (* h rh)) (/ h 4)) w nrow gap_row 
	     (- (* h (- 1 rh)) (/ h 4)))
)

(nt_def_type "perg_box" 'perg_box
	     '(("xo" . 0) ("yo" . 0) ("zo" . 0) ("w" . 120)
	       ("nrow" . 5) ("gap_row" . 120)  ("h" . 180) 
	       ("rh" . 0.85))
)

(defun perg_box (xo yo zo pw nrow gap_row  ph rh 
	   / c1 c2 box1_c_plist box2_c_plist)
  (setq box1_c_plist
	(list (cons "xo" xo)
	      (cons "yo" yo)
              (cons "zo" zo)
	      (cons "w" pw)
	      (cons "nrow" nrow)
	      (cons "gap_row" gap_row)
	      (cons "h" (* ph rh))
	      ))

  (setq box2_c_plist
	(list (cons "xo" xo)
	      (cons "yo" yo)
	      (cons "zo" (+ (+ zo (* rh ph)) (/ (* ph (- 1 rh)) 4)))
	      (cons "w" pw)
      	      (cons "t_nrow"  nrow)
	      (cons "t_gap_row"  gap_row)
	      (cons "h" (- (* ph (- 1 rh)) (/ (* ph (- 1 rh)) 4)))
	      ))

  (setq c1 (list "perg_box1" nil box1_c_plist))
  (setq c2 (list "perg_box2" nil box2_c_plist))
  (nt_composit (list c1 c2))
)


(nt_def_trans '("rect_box") "perg_box" 'r_box2p_box
	      nil 'replace)

(defun r_box2p_box (rect_list trans_plist /
		    rect c_plist f_plist rect_plist)
  (setq rect (car rect_list))
  (setq rect_plist (nt_plist rect))
  (setq c_plist (list (cons "xo" (nt_val "xo" rect_plist))
		      (cons "yo" (nt_val "yo" rect_plist))
		      (cons "zo" (nt_val "zo" rect_plist))
		      (cons "pw" (nt_val "w" rect_plist))
		      (cons "ph" (nt_val "h" rect_plist))
		     		      ))
  (setq f_plist (list (cons "nrow" 5)
		      (cons "gap_row" 120)
		      (cons "rh" 0.85)
		      ))
  (list f_plist c_plist)
)

(nt_def_trans '("perg_box1") "perg_rect_shaft" 'box12rec_shaft
	         nil 'replace)
(nt_def_trans '("perg_box1") "perg_round_shaft" 'box12rou_shaft
	         nil 'replace)
(nt_def_trans '("perg_box2") "perg_capital_beam" 'box22b_capital
	         nil 'replace)
(nt_def_trans '("perg_box2") "perg_capital_frame" 'box22f_capital
	         nil 'replace)

(defun box12rec_shaft (cube_list trans_plist /
		       cube c_plist f_plist cube_plist)
  (setq cube (car cube_list))
  (setq cube_plist (nt_plist cube))
  (setq c_plist (list (cons "xo" (- (nt_val "xo" cube_plist)
				 (/ (nt_val "w" cube_plist) 2)))
		      (cons "yo" (- (nt_val "yo" cube_plist)
				 (/ (nt_val "w" cube_plist) 2)))
		      (cons "zo" (nt_val "zo" cube_plist))
		      
		      (cons "h" (nt_val "h" cube_plist))
		      (cons "nrow" (+ 1 (nt_val "nrow" cube_plist)))
		      (cons "gap_row" (nt_val "gap_row" cube_plist))
		      (cons "gap_col" (nt_val "w" cube_plist))
		      ))
  (setq f_plist (list (cons "w" 12)
		      (cons "d" 12)))
  (list f_plist c_plist)
)


(defun box12rou_shaft (cube_list trans_plist /
		       cube c_plist f_plist cube_plist)
  (setq cube (car cube_list))
  (setq cube_plist (nt_plist cube))
  (setq c_plist (list (cons "xo" (- (nt_val "xo" cube_plist)
				 (/ (nt_val "w" cube_plist) 2)))
		      (cons "yo" (- (nt_val "yo" cube_plist)
				 (/ (nt_val "w" cube_plist) 2)))
		      (cons "zo" (nt_val "zo" cube_plist))
		      
		      (cons "h" (nt_val "h" cube_plist))
		      (cons "nrow" (+ 1 (nt_val "nrow" cube_plist)))
		      (cons "gap_row" (nt_val "gap_row" cube_plist))
		      (cons "gap_col" (nt_val "w" cube_plist))
		      ))
  (setq f_plist (list (cons "r" 9)))
  (list f_plist c_plist)
)

(defun box22b_capital (cube_list trans_plist /
		       cube c_plist f_plist cube_plist)
  (setq cube (car cube_list))
  (setq cube_plist (nt_plist cube))
  (setq c_plist (list (cons "xo" (- (nt_val "xo" cube_plist)
				 (/ (nt_val "w" cube_plist) 2)))
		      (cons "yo" (- (nt_val "yo" cube_plist)
				 (/ (nt_val "w" cube_plist) 2)))
		      (cons "zo" (- (nt_val "zo" cube_plist) 
				    (- (/ (* (nt_val "h" cube_plist) 4) 3) 
				       (nt_val "h" cube_plist))))
				       
		      (cons "gap_col" (nt_val "w" cube_plist))
		      (cons "nrow" (+ 1 (* (nt_val "t_nrow" cube_plist) 4)))
		      (cons "gap_row" (/ (nt_val "t_gap_row" cube_plist) 4))
		      (cons "w" (/ (nt_val "h" cube_plist) 8))
		      (cons "t" (/ (nt_val "h" cube_plist) 2))
		      ))
  (setq f_plist  (list

		      (cons "wr" 1)
		      (cons "tr" 1.5)
		      (cons "cant" 6)
		     
		      
	              ))
  (list f_plist c_plist)           
)

(defun box22f_capital (cube_list trans_plist /
		       cube c_plist f_plist cube_plist)
  (setq cube (car cube_list))
  (setq cube_plist (nt_plist cube))
  (setq c_plist (list (cons "xo" (- (nt_val "xo" cube_plist)
				 (/ (nt_val "w" cube_plist) 2)))
		      (cons "yo" (- (nt_val "yo" cube_plist)
				 (/ (nt_val "w" cube_plist) 2)))
		      (cons "zo" (- (nt_val "zo" cube_plist) 
				    (-  (/ (* (nt_val "h" cube_plist) 4) 3)
				     (nt_val "h" cube_plist))))
		      (cons "gap_col" (nt_val "w" cube_plist))
		      (cons "nrow" (+ 1 (* (nt_val "t_nrow" cube_plist) 4)))
		      (cons "gap_row" (/ (nt_val "t_gap_row" cube_plist) 4))
		      (cons "gap_h" (nt_val "h" cube_plist))
		      (cons "w" (/ (nt_val "h" cube_plist) 12))
		      ))
  (setq f_plist  nil)
  (list f_plist c_plist)
)

;Test the function defined above with various parameter values.
;(defun demo()
;  (command "limits" (list -300  -300) (list 300 300))
 
; (perg_rect_beam  0 0 0 12 12 180 0.75 0.25 10 2 120 120 3 1200 12 1 1.5
;		   6 41 1 30 120)
;  (command "shade" )   
;  (redraw)
;)
;(princ "(demo)" )
;(terpri)