A style question
in [Lisp]
|
From: nallen05 on 28 Feb 2007 12:32 Rob Warnock wrote: > <job-271842874(a)craigslist.org> wrote: > +--------------- > | Another friend of mine commenting on the same FizzBuzz thread supplied > | the following Python code. It certainly is concise: > | > | for i in xrange(1,101): > | print(str(i), "Fizz", "Buzz", "FizzBuzz")[(i%3==0)|(i%5==0)<<1] > | > | I thought about retrofitting my Ruby version as an exercise, but alas, > | Ruby doesn't allow shifting truth to the left :) > | > | Forgive my ignorance, but is anything like the boolean bit shifting > | technique used in the Python code above possible in Lisp? No big loss if > | it isn't, just curious. > +--------------- > > Well, sort of... ;-} ;-} > > This one is both efficient -- *no* MOD calls at all! -- > *and* so ugly only a parent could love it: ;-} ;-} > > (defun fizz-buzz (n) > (loop for i from 1 to n > and three-p in '#3=(nil nil t . #3#) > and five-p in '#5=(nil nil nil nil t . #5#) > do (format t "~a~%" (cond > ((and three-p five-p) "FizzBuzz") > (three-p "Fizz") > (five-p "Buzz") > (t i))))) > This is awsome, Rob ;-) But I can make one that's faster AND uglier! (defmacro def-fizz-buzz () (let (l) (do* ((i 1 (incf i)) (m3p (zerop (mod i 3)) (zerop (mod i 3))) (m5p (zerop (mod i 5)) (zerop (mod i 5)))) ((> i 15)) (setq l (list* `(print ,(cond ((and m3p m5p) "FizzBuzz") (m3p "Buzz") (m5p "Fizz") (t 'y))) '(when (> y x) (return)) '(incf y) l))) `(defun fizz-buzz (x) (let ((y 0)) (loop ,@(reverse l)))))) CL-USER> (macroexpand-1 '(def-fizz-buzz)) => (DEFUN FIZZ-BUZZ (X) (LET ((Y 0)) (LOOP (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT Y) (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT Y) (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT "Buzz") (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT Y) (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT "Fizz") (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT "Buzz") (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT Y) (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT Y) (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT "Buzz") (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT "Fizz") (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT Y) (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT "Buzz") (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT Y) (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT Y) (INCF Y) (WHEN (> Y X) (RETURN)) (PRINT "FizzBuzz"))))
From: Richard M Kreuter on 28 Feb 2007 12:38 "Tim Bradshaw" <tfb+google(a)tfeb.org> writes: > On Feb 28, 3:40 pm, Richard M Kreuter <kreu...(a)progn.net> wrote: > >> (dotimes (i 100) >> (format t "~[~[FizzBuzz~:;Fizz~]~:;~[Buzz~:;~D~]~]~%" (mod i 3) (mod i 5) i)) >> >> Best I could do on one cup of coffee. > > Good, but you'd get extra points for avoiding the explicit FizzBuzz in > there. Off the top of my head I think: > (format t "~&~[Fizz~;~]~[Buzz~;~D~]~%" (mod i 3) (mod i 5) i). But > I'd have to check, and it's not really squiggly enough. I think you mean "~&~[Fizz~:;~]~[Buzz~:;~D~]~%" right? Something like that was my first hunch, but it will print the integer next to Fizz when (and (zerop (mod i 3)) (plusp (mod i 5))), * (let ((i 6)) (format t "~&~[Fizz~:;~]~[Buzz~:;~D~]~%" (mod i 3) (mod i 5) i)) -| Fizz6 => NIL * (let ((i 9)) (format t "~&~[Fizz~:;~]~[Buzz~:;~D~]~%" (mod i 3) (mod i 5) i)) -| Fizz9 => NIL Here's one that avoids the explicit FizzBuzz, and adds /seven/ squiggles to my first stab: (dotimes (i 100) (format t "~[~[~3@*~A~A~:;~3@*~A~]~:;~[~4@*~A~:;~D~]~]~%" (mod i 3) (mod i 5) i "Fizz" "Buzz")) Better? -- RmK
From: John Thingstad on 28 Feb 2007 13:09 On Wed, 28 Feb 2007 18:38:48 +0100, Richard M Kreuter <kreuter(a)progn.net> wrote: > > (dotimes (i 100) > (format t "~[~[~3@*~A~A~:;~3@*~A~]~:;~[~4@*~A~:;~D~]~]~%" > (mod i 3) (mod i 5) i "Fizz" "Buzz")) > > Better? > Perfect! I rivals Perl in clarity of exposition.. -- Using Opera's revolutionary e-mail client: http://www.opera.com/mail/
From: Frank Buss on 28 Feb 2007 13:39 job-271842874(a)craigslist.org wrote: > 1) In "ANSI Common Lisp", Graham makes the following comments: > "The loop macro was originally designed to help inexperienced Lisp > users write iterative code...Unfortunately, loop is more like English > than its designers ever intended...to understand it in the abstract is > almost impossible...For such reasons, the use of loop cannot be > recommended." I don't agree. You can learn the basics by reading loop examples. Once you know how each loop word works, all you need is the BNF, if you forgot something. The more you use it, the more you learn the grammar and the easier it is to use it. Like all good DSLs, it helps a lot to write short and easy to understand code for the task for which it is designed: iterating. -- Frank Buss, fb(a)frank-buss.de http://www.frank-buss.de, http://www.it4-systems.de
From: Frank Buss on 28 Feb 2007 13:47
Ken Tilton wrote: > You refer of course to the Cello code to create a 3-D oblong button of > variable thickness with rounded corners of variable radius: Yes, that's really ugly :-) Did you thought about using your dataflow paradigm to create graphics? Something similar would be to use higher order functions and combinators. The code below creates buttons like this: http://www.frank-buss.de/tmp/buttons.png In LispWorks 4.3.7 it is not very fast, but SBCL needs not many seconds :-) (defparameter *width* 200) (defparameter *height* 70) (defstruct color (r 0.0 :type single-float) (g 0.0 :type single-float) (b 0.0 :type single-float) (a 0.0 :type single-float)) (defun rgb-2-color (rgb) (declare (type fixnum rgb) (make-color :r (/ (ldb (byte 8 16) rgb) 255.0) :g (/ (ldb (byte 8 8) rgb) 255.0) :b (/ (ldb (byte 8 0) rgb) 255.0))) (defun middle (a b) (/ (+ a b) 2.0)) (defconstant +transparent+ (make-color :r 1.0 :g 1.0 :b 1.0 :a 1.0)) (defconstant +white+ (make-color :r 1.0 :g 1.0 :b 1.0)) ;(defconstant +color0+ (rgb-2-color #xeaeaa2)) ;(defconstant +color1+ (rgb-2-color #xee4f23)) ;(defconstant +color0+ (rgb-2-color #x999999)) ;(defconstant +color1+ (rgb-2-color #x444444)) (defconstant +color0+ (rgb-2-color #xa2fafa)) (defconstant +color1+ (rgb-2-color #x23ee4f)) (defconstant +color-avg+ (make-color :r (middle (color-r +color0+) (color-r +color1+)) :g (middle (color-g +color0+) (color-g +color1+)) :b (middle (color-b +color0+) (color-b +color1+)))) (defun transparentp (color) (= 1.0 (color-a color))) (defun disc (&key x0 y0 radius) (let ((r2 (* radius radius))) (lambda (x y) (let ((xc (- x x0)) (yc (- y y0))) (let ((r (+ (* xc xc) (* yc yc)))) (<= r r2)))))) (defun rect (&key x0 y0 x1 y1) (lambda (x y) (and (>= x x0) (<= x x1) (>= y y0) (<= y y1)))) (defun rounded-rect (&key x0 y0 x1 y1 radius) (let ((x0-i (+ x0 radius)) (y0-i (+ y0 radius)) (x1-i (- x1 radius)) (y1-i (- y1 radius))) (lambda (x y) (let ((rect (rect :x0 x0 :y0 y0 :x1 x1 :y1 y1)) (top-left-disc (disc :x0 x0-i :y0 y0-i :radius radius)) (top-right-disc (disc :x0 x1-i :y0 y0-i :radius radius)) (bottom-left-disc (disc :x0 x0-i :y0 y1-i :radius radius)) (bottom-right-disc (disc :x0 x1-i :y0 y1-i :radius radius))) (cond ((and (< x x0-i) (< y y0-i)) (funcall top-left-disc x y)) ((and (> x x1-i) (< y y0-i)) (funcall top-right-disc x y)) ((and (< x x0-i) (> y y1-i)) (funcall bottom-left-disc x y)) ((and (> x x1-i) (> y y1-i)) (funcall bottom-right-disc x y)) (t (funcall rect x y))))))) (defun gradient (&key color0 color1 x0 x1) (let ((r0 (color-r color0)) (g0 (color-g color0)) (b0 (color-b color0)) (r1 (color-r color1)) (g1 (color-g color1)) (b1 (color-b color1)) (dx (- x1 x0))) (lambda (x) (cond ((< x x0) color0) ((>= x x1) color1) (t (setf x (/ (- x x0) dx)) (make-color :r (+ (* (- r1 r0) x) r0) :g (+ (* (- g1 g0) x) g0) :b (+ (* (- b1 b0) x) b0))))))) (defun blur (&key mask) (lambda (x y) (let ((sum 0.0)) (loop for xo from -4 to 4 do (loop for yo from -4 to 4 do (when (funcall mask (+ x xo) (+ y yo)) (incf sum (/ (+ (* xo xo) (* yo yo) 2.0)))))) (/ sum 2.0)))) (defun add (fun1 fun2) (lambda (x y) (let ((c1 (funcall fun1 x y)) (c2 (funcall fun2 x y))) (cond ((transparentp c1) c2) ((transparentp c2) c1) (t (make-color :r (+ (color-r c1) (color-r c2)) :g (+ (color-g c1) (color-g c2)) :b (+ (color-b c1) (color-b c2)))))))) (defun neg-mul (color-fun channel-fun) (lambda (x y) (let ((color (funcall color-fun x y)) (channel (funcall channel-fun x y))) (cond ((transparentp color) color) (t (when (> channel 1) (setf channel 1)) (when (< channel 0) (setf channel 0)) (let ((channel2 (- 1 channel))) (make-color :r (+ (* channel (color-r +color0+)) (* channel2 (color-r color))) :g (+ (* channel (color-g +color0+)) (* channel2 (color-g color))) :b (+ (* channel (color-b +color0+)) (* channel2 (color-b color)))))))))) (defun fill-gradient-vertical (&key gradient function) (lambda (x y) (if (funcall function x y) (funcall gradient y) +transparent+))) (defun fill-solid (&key function color) (lambda (x y) (if (funcall function x y) color +transparent+))) (defun overlay (&key background foreground) (lambda (x y) (let ((foreground-color (funcall foreground x y))) (if (transparentp foreground-color) (funcall background x Y) foreground-color)))) (defun xor (fun1 fun2) (lambda (x y) (not (eql (funcall fun1 x y) (funcall fun2 x y))))) (defun channel-and (channel-fun binary-fun) (lambda (x y) (if (funcall binary-fun x y) (funcall channel-fun x y) 0))) (defun button (&key x0 y0 x1 y1) (let* ((radius 15.0) (stroke 1.0) (outer-rect (rounded-rect :x0 (- x0 stroke) :y0 (- y0 stroke) :x1 (+ x1 stroke) :y1 (+ y1 stroke) :radius (+ radius stroke))) (inner-rect (rounded-rect :x0 x0 :y0 y0 :x1 x1 :y1 y1 :radius radius)) (ring (xor outer-rect inner-rect)) (inner-glow (channel-and (blur :mask ring) inner-rect)) (gradient (gradient :color0 +color0+ :color1 +color1+ :x0 y0 :x1 y1)) (filled-outer-rect (fill-solid :function outer-rect :color +color-avg+)) (filled-inner-rect (fill-gradient-vertical :gradient gradient :function inner-rect))) (overlay :background filled-outer-rect :foreground (neg-mul filled-inner-rect inner-glow)))) (defun anti-alias (function) (lambda (x y) (let ((c0 (funcall function x y)) (c1 (funcall function (+ x 0.5) y)) (c2 (funcall function x (+ y 0.5))) (c3 (funcall function (+ x 0.5) (+ y 0.5)))) (make-color :r (/ (+ (color-r c0) (color-r c1) (color-r c2) (color-r c3)) 4.0) :g (/ (+ (color-g c0) (color-g c1) (color-g c2) (color-g c3)) 4.0) :b (/ (+ (color-b c0) (color-b c1) (color-b c2) (color-b c3)) 4.0) :a (/ (+ (color-a c0) (color-a c1) (color-a c2) (color-a c3)) 4.0))))) (defun color-byte (color) (let ((result (floor (* 255.0 color)))) (cond ((> result 255) 255) ((< result 0) 0) (t result)))) (defun red-byte (color) (color-byte (color-r color))) (defun green-byte (color) (color-byte (color-g color))) (defun blue-byte (color) (color-byte (color-b color))) (defun paint (function &optional (filename "c:/tmp/test.tga")) (with-open-file (tga filename :direction :output :if-exists :supersede :element-type 'unsigned-byte) (dolist (byte (list 0 0 2 0 0 0 0 0 0 0 0 0 (mod *width* 256) (floor *width* 256) (mod *height* 256) (floor *height* 256) 24 0)) (write-byte byte tga)) (loop for y from (1- *height*) downto 0 do (loop for x from 0 below *width* do (let ((color (funcall function x y))) (when (transparentp color) (setf color +white+)) (write-byte (blue-byte color) tga) (write-byte (green-byte color) tga) (write-byte (red-byte color) tga))))) #+:lispworks (sys:call-system (format nil "c:\\Programme\\Adobe\\Photoshop 7.0\\Photoshop.exe ~a" filename))) (defun test () (paint (anti-alias (button :x0 10.0 :y0 10.0 :x1 190.0 :y1 60.0)))) -- Frank Buss, fb(a)frank-buss.de http://www.frank-buss.de, http://www.it4-systems.de |