Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]

Groups > comp.lang.forth > #37624

Eye-drawing

Show all headers | View raw

Alan Crowe wrote:

> After this general purpose preamble
> 
> (defmacro define-namespace (namespace operator)
>   `(defmacro ,namespace (names &body code)
>     (flet ((make-macro-def(name)
>              `(,name (&rest args) `(,',',operator ,',name ,@args))))
>       `(macrolet ,(mapcar #'make-macro-def names) ,@code))))
> 
> (define-namespace with-functions funcall)
> 
> (defmacro defcurry (name primary-lambda-list
>                     secondary-lambda-list
>                     &body code)
>   `(defun ,name ,primary-lambda-list
>     (lambda ,secondary-lambda-list ,@code)))
> 
> I continue by writing
> 
> (defun show-image (f)
>   (format t "~&~{~A~%~}" (render f)))
> 
> (defun render (f)
>   "Build list of strings to visualise f"
>   (loop for y below 40
>         collect (coerce (loop for x below 40
>                               collect (if (funcall f x y)
>                                           #\*
>                                           #\Space))
>                         'string)))
> 
> (defun circle (x y)
>   (< (+ (expt x 2)
>         (expt y 2))
>      1))
> 
> (defcurry scale (factor f)(x y)
>   (funcall f (/ x factor) (/ y factor)))
> 
> (defcurry translate (dx dy f)(x y)
>   (funcall f (- x dx) (- y dy)))
> 
> (defcurry combine (op f g)(x y)
>   (with-functions (op f g)
>     (op (f x y)(g x y))))
> 
> (defun ring (inner-radius outer-radius)
>   (combine (complement #'eql)
>            (scale inner-radius #'circle)
>            (scale outer-radius #'circle)))
> 
> (defun add (f g)
>   (combine (lambda(a b)(or a b)) f g))
> 
> (defun the-eye ()
>   (let ((pupil (translate 10 15 (ring 5 6)))
>         (ball (translate 15 15 (ring 10 12))))
>     (add pupil ball)))
> 
> and obtain
> 
> CL-USER> (show-image (the-eye))
> 
> 
> 
>            *********
>          *************
>         ***         ***
>        ***           ***
>       **               **
>      ***               ***
>      *********          **
>     ****     **          **
>     ***       **         **
>     **         *         **
>     **         *         **
>     **         *         **
>     **         *         **
>     **         *         **
>     ***       **         **
>     ****     **          **
>      *********          **
>      ***               ***
>       **               **
>        ***           ***
>         ***         ***
>          *************
>            *********

Oforth:

func: one-line(fn, y)
{ seqFrom(0, 39)
  map(#[y swap fn perform ifTrue: ['*'] else: [' '] ])
  charsAsString }

func: render(fn) { seqFrom(0, 39) map(#[ one-line(fn) ]) }

func: show-image(fn) { fn render apply(#println) }

func: circle { sq swap sq + 1 < }

func: scale(factor, fn)
{ #[ factor asFloat /  swap  factor asFloat /  swap  fn perform] }

func: translate(dx, dy, fn) { #[ dy -  swap  dx -  swap  fn perform] }

func: combine(op, f, g)
{|x y| #[ -> y -> x op perform( f perform(x,y), g perform(x,y) ) ]}

func: ring(inner-rad, outer-rad)
{ combine( #[== not], scale(inner-rad,#circle), scale(outer-rad,#circle)) }

func: or-funcs(f, g) { combine( #or, f, g ) }

func: the-eye
{ or-funcs( translate(10, 15, ring(5, 6)), translate(15, 15, ring(10, 12))) }

the-eye show-image



           *********
         *************
        ***         ***
       ***           ***
      **               **
     ***               ***
     *********          **
    ****     **          **
    ***       **         **
    **         *         **
    **         *         **
    **         *         **
    **         *         **
    **         *         **
    ***       **         **
    ****     **          **
     *********          **
     ***               ***
      **               **
       ***           ***
        ***         ***
         *************
           *********

Back to comp.lang.forth | Previous | Next | Find similar | Unroll thread

Thread

Eye-drawing "WJ" <w_a_x_man@yahoo.com> - 2015-03-24 21:00 +0000

csiph-web