Aalto Lisp

I wrote a Lisp routine for an M. Sc. 20 years ago but can't get it work, could someone help, it's an experiment based on the work of the architect Alvar Aalto

(defun dtr (a)
 (* pi (/ a 180.0))
)

(defun addz (pos inc / z)
(setq z (caddr pos)
          z (+ inc z)
          pos (list (car pos) (cadr pos) z)
          )
)

(defun rnge (bot top)
(setq r (rand (- top bot))
	r (+ bot r))
)
;
(defun rand (range / x z r)
(if (not seed) (setq seed 350))
(setq x (1 + (* seed 2197.0))
           z (fix (/ x 4096.0))
           seed (fix (- x (* z 4096.0)))
           r (fix (1 + (abs (* (/ seed 4096.0) (- range 1.0)))))
)
)		
(defun dvolp (pcn)
(setq radb (distance ps pe)
	angb (angle ps pcn)
	psb (polar ps ang radb)
	peb (polar pe (* ang anginc) radb)
	)
)
;
(defun drawvolp (pcn)
(setq radb (distance ps pe)
	angb (angle ps pcn)
	psb (polar ps ang radb)
	peb (polar pe (+ ang anginc) radb)
	radc (distance psb speb)
	angc (angle psb speb)
	angd (angle peb pe)
	ange (angle ps pe)
	angf (angle pe ps)
	angg (angle peb pe)
		psc (polar psb angc (/ radc 2))
		psoa (polar psb angc (/ radc 2))
		psob (polar ps angc radc)
		psn (polar psob ange radc)
		peoa (polar pe angg (/ radc 2))
		peob (polar pe angg radc)
		pen (polar peob angf radc)
			htrad1 (distance psc peb)
			htrad2 (distance psoa peoa)
			htrad3 (distance psob peob)
				psnht (addz psn htrad3)
				psoaht (addz psoa htrad2)
				pscht (addz psoa htrad1)
				penht (addz pen htrad3)
				peoaht (addz peoa htrad2)
				pebht (addz peb htrad1)
					)
			(command "layer" "m" "line" "c" 5 "" "")
			(command "3dface" psoa psoaht pscht psc "")
			(command "3dface" psc pscht pebht peb"")
			(command "3dface" peb pebht peoaht peoa "")
			(command "3dface" peoa peoaht penht pen "")
			(command "3dface" pen penht psnht psn "")
			(command "3dface" psn psnht psoaht psoa "")
			(command "3dface" pebht peoaht penht pebht "")
			(command "3dface" pscht psoaht psnht pscht "")
			(command "3dface" pebht penht psnht pscht "")
)

(defun dvolreg (pcn)
(setq radt (fix (* (distance pte pts) (sqrt 2)))
	anga (angle pts pcn)
	angb (angle pte pcn)
	ptsb (polar pts anga radt)
	pteb (polar pte angb radt)
	htrad (distance pte pts)
		ptsht (addz pts htrad)
		ptsbht (addz ptsb htrad)
		pteht (addz pte htrad)
		ptebht (addz pteb htrad)
		p1val (rnge 1 (fix (/ radt 2.7)))
		 outang (angle pte pts)
		 innang (angle pteb ptsb)
		 ptemid (polar pte outang (/ htrad 2))
		 ptebmid (polar pteb innang (/ (distance pteb ptsb) 2))
		 midang (angle ptebmid ptemid)
		 p4val (rnge 1 p1val)
		 npte1 (polar pte angb p4val))
		(if (>= cnter 1) (setq npte1 npts1))
		(if (= cnter 0) (setq p2val (rnge 1 (fix (/ htrad 6)))))
		(if (= cnter 0) (setq p3val (rnge 1 p1val)))
	(setq npte2 (polar npte1 (+ angb (dtr 90)) p2val)
		npte3 (polar npte2 midang p3val)
		npts1 (polar pts anga p4val)
		npts2 (polar npts1 (- anga (dtr 90)) p2val)
		npts3 (polar npts2 midang p3val)
		npte1ht (addz npte1 htrad)
		npte2ht (addz npte2 htrad)
		npte3ht (addz npte3 htrad)
		npts1ht (addz npts1 htrad)
		npts2ht (addz npts2 htrad)
		npts3ht (addz npts3 htrad))
	(command "layer" "m" "line" "c" 5 "" "")
	(command "3dface" pteb ptebht npte1ht npte1 "")
	(command "3dface" npte1 npte1ht npte2ht npte2 "")
	(command "3dface" npte2 npte2ht npte3ht npte3 "")
	(command "3dface" npte3 npte3ht npts3ht npts3 "")
	(command "3dface" npts3 npts3ht npts2ht npts2 "")
	(command "3dface" npts2 npts2ht npts1ht npts1 "")
	(command "3dface" npts1 npts1ht ptsbht ptsb "")
	(command "3dface" ptsb ptsbht ptebht pteb "")
	(command "3dface" ptebht npte1ht npte2ht npte3ht "")
	(command "3dface" npts3ht npts2ht npts1ht ptsbht "")
	(command "3dface" ptebht npte3ht npts3ht ptsbht "")
(setq pteb ptsb
	pte pts)
)

(defun prog ()
(command "erase" (ssget "x") "")
(command "redraw")
(setq small (list 300 300)
      large (list 1000 1000))
(command "zoom" "w" small large)
(command "layer" "m" "arcs" "c" 3 "" "")
(setvar "cmdecho" 0)
(setvar "pdmode" 35)
(setvar "pdsize" 1)
(setq pc (getpoint "\nPick a Point: ")
	rd (getpoint pc "\nPick Radius and Start Angle: ")
	anginc (getangle "\nEnter Angle in Degrees: ")
      rad (distance pc rd)
	ang (angle pc rd)
	ps (polar pc ang rad)
	pe (polar pc (+ ang anginc) rad)
			)
(command "arc" "c" pc ps pe)
(setq cntr (fix (/ 360 (atof (angtos anginc))))
	cntb (- (/ cntr 2) 1)
		n "t")
(while n
(setq speb peb
	ang (angle pe pc)
	angrev (angle pc pe)
	rad (* rad (sqrt 2))
	pcb pc
	pc (polar pe ang rad)
	ps pe
	pe (polar pc (+ angrev anginc) rad))
	(command "layer" "m" "arcs" "c" 3 "" "")
	(command "arc" "c" pc ps pe)
	(if (> cntr cntb) (dvolp pcb))
	(if (<= cntr cntb) (drawvolp pcb))
	(command "layer" "m" "pnts" "c" 1 "" "")
	(command "point" pe)
		(setq cntr (- cntr 1))
		(if (= cntr 0) (setq n nil))
	(command "layer" "m" "arcs" "c" 3 "" "")
	(command "arc" "c" pc ps pe)
		)
		(command "zoom" "e")
)

(defun reg ()
(command "erase" (ssget "x") "")
(setq small (list 300 300)
      large (list 1000 1000))
(command "zoom" "w" small large)
(command "redraw")
(command "layer" "m" "arcs" "c" 3 "" "")
(setvar "cmdecho" 0)
(setvar "pdmode" 35)
(setvar "pdsize" 1)
(setq pc (getpoint "\nPick a Point: ")
	rd (getpoint pc "\nPick Radius and Start Angle: ")
	anginc (getangle "\nEnter Angle in Degrees: ")
      seed (getreal "\nEnter Seed: ")
	pc1 pc
	rad (distance pc rd)
	ang (angle pc rd)
	ps (polar pc ang rad)
	pe (polar pc (+ ang anginc) rad))
		(command "pline")
		(setq cntr (fix (/ 360 (atof (angtos anginc))))
			cntb (/ cntr 2)
		n "t")
	(while n
		(setq ang (angle pe pc)
			angrev (angle pc pe)
			rad (* rad (sqrt 2))
			pcb pc
			pc (polar pe ang rad)
			ps pe
			pe (polar pc (+ angrev anginc) rad))
	(if (<= cntr cntb) (command ps "arc" "ce" pc pe))
	(if (= cntr cntb) (setq ps1 ps))
		(setq cntr (- cntr 1))
	(if (< cntr 0) (setq n nil))
	)
		(command "")
		(command "line" ps1 pe "")
		(command "layer" "m" "pnts" "c" 1 "" "")
		(command "zoom" "e" "")
		(command "divide" ps (rnge 5 15))
			(setq pte pe
				ss1 (ssget "x" (list (cons 0 "point")))
				num (sslength ss1)
				cnter 0)
			(repeat num
		(setq pts (cdr (assoc 10 (entget (ssname ss1 cnter)))))
				(dvolreg pcb)
				(setq cnter (1+ cnter))
				)
				(command "zoom" "e")
)

 
(defun c:try ()
	(initget "Prog Reg")
	(setq answer (getkword "\nWhat do you want <Prog/Reg>? "))
	(cond
		((= answer "Prog") (prog))
		((= answer "Reg") (reg))
	)
)

Please read:

http://www.cadtutor.net/forum/showthread.php?9184-Code-posting-guidelines

I notice two things:

1.

(command "erase" (ssget "x") "")

Should be:

(if (setq ss (ssget "x")) (command "erase" ss ""))

2.

(1 + ...)

Should be (2x):

(1+ ...)

I would wrote the main function like this:

(defun c:test ( / answer )
(initget "Prog Reg")
(or (setq answer (getkword "\nWhat do you want [Prog/Reg] <Prog> ? ")) (setq answer "Prog"))
(cond
	((and (= answer "Prog") (= 'SUBR (type prog))) (princ "\nChoosed: Prog") (prog))
	((and (= answer "Reg") (= 'SUBR (type reg))) (princ "\nChoosed: Reg") (reg))
)
(princ)
)

And these subfunctions like this:

(defun addz (pos inc / z)
(and 
	pos (listp pos) (numberp inc)
	(setq pos (list (car pos) (cadr pos) (+ inc (caddr pos))))
)
pos
)

(defun rnge (bot top)
(and
	(apply 'and (mapcar 'numberp (list bot top)))
	(setq	r (+ bot (rand (- top bot))))
)
r
)

(defun rand (range / x z r)
(and
	(or (numberp seed) (setq seed 350))
	(numberp range)
	(setq x (1+ (* seed 2197.0)))
	(setq z (fix (/ x 4096.0)))
	(setq seed (fix (- x (* z 4096.0))))
	(setq r (fix (1+ (abs (* (/ seed 4096.0) (- range 1.0))))))
)
r
)

(defun dvolp (pcn)
(and
	pcn (listp pcn) (apply 'and (mapcar 'numberp pcn))
	(setq radb (distance ps pe))
	(setq angb (angle ps pcn))
	(setq psb (polar ps ang radb))
	(setq peb (polar pe (* ang anginc) radb))
)
peb
)

Although I am not sure whats up with the global arguments, so I didn't touched them (just provided additional checks in these subfunctions).

And also these rows like inside of the (drawvolp) function:

(command "layer" "m" "line" "c" 5 "" "")
(command "3dface" psoa psoaht pscht psc "")
(command "3dface" psc pscht pebht peb"")
(command "3dface" peb pebht peoaht peoa "")
(command "3dface" peoa peoaht penht pen "")
(command "3dface" pen penht psnht psn "")
(command "3dface" psn psnht psoaht psoa "")
(command "3dface" pebht peoaht penht pebht "")
(command "3dface" pscht psoaht psnht pscht "")
(command "3dface" pebht penht psnht pscht "")

IMO, is better to be written like this:

(command
"_.LAYER" "m" "line" "c" 5 "" ""
"_.3DFACE" "_non" psoa "_non" psoaht "_non" pscht "_non" psc ""
"_.3DFACE" "_non" psc "_non" pscht "_non" pebht "_non" peb ""
"_.3DFACE" "_non" peb "_non" pebht "_non" peoaht "_non" peoa ""
"_.3DFACE" "_non" peoa "_non" peoaht "_non" penht "_non" pen ""
"_.3DFACE" "_non" pen "_non" penht "_non" psnht "_non" psn ""
"_.3DFACE" "_non" psn "_non" psnht "_non" psoaht "_non" psoa ""
"_.3DFACE" "_non" pebht "_non" peoaht "_non" penht "_non" pebht ""
"_.3DFACE" "_non" pscht "_non" psoaht "_non" psnht "_non" pscht ""
"_.3DFACE" "_non" pebht "_non" penht "_non" psnht "_non" pscht ""
)

And also, when you write setq-s like this:

(setq pc (getpoint "\nPick a Point: ")
rd (getpoint pc "\nPick Radius and Start Angle: ")
anginc (getangle "\nEnter Angle in Degrees: ")
seed (getreal "\nEnter Seed: ")
...
)

This would evaluate only the last setq variable (as Tharwat taught me), which in your case is:

... pe (polar pc (+ ang anginc) rad)

So I would suggest the classical way to separate the prompts for user inputs, from the rest variables that the routine proceeds with:

(if
(and
	(setq pc (getpoint "\nPick a Point: "))
	(setq rd (getpoint pc "\nPick Radius and Start Angle: "))
	(setq anginc (getangle "\nEnter Angle in Degrees: "))
	(setq seed (getreal "\nEnter Seed: "))
)
(progn
	(setq
		pc1 pc
		rad (distance pc rd)
		ang (angle pc rd)
		ps (polar pc ang rad)
		pe (polar pc (+ ang anginc) rad)
	)
	...
); progn
); if

Sorry, no full revision - the global variables passing thru the subfuncs and these calculations are confusing for me

Thank you so much, when I get it working I'll send you a copy

Hi again, if you send me an email address I'll post you a copy of the paper I wrote so that you can get the full gist of how it used to work, many thanks for your help this morning,

john.cavendish@gmail.com

Hi again, if you send me an email address I'll post you a copy of the paper I wrote so that you can get the full gist of how it used to work, many thanks for your help this morning,

 

john.cavendish@gmail.com

Just upload what do you have in here (cadtutor). We are not the only guys who can help you.

the paper is in a pdf attached

second part of the paper

the code you already have seen

i got it working