A Racket Friendly Super-Tiny Logo Implementation

ProgrammingPraxis covered one of my favorite topics today: Turtle Graphics, aka LOGO. I couldn't resist taking the solution provided and adapting it to work with the racket/draw library.

There are definitely better implementations of Turtle Graphics out there, but this was a fun little exercise to put together.

Here's my solution to the provided question:

#lang racket

;;
;; Implement the most basic of logo functionality for:
;;   http://programmingpraxis.com/2012/01/03/turtle-graphics/
;;

(require racket/gui
         racket/draw)

(struct context (pos heading canvas dc) #:prefab #:mutable)
(define *ctx* (context (cons 0 0) 0 #f #f))

(define no-pen (new pen% [style 'transparent]))
(define black-pen (new pen% [color "black"] [width 2]))


(define (penup)
  (send (context-dc *ctx*) set-pen no-pen))

(define (pendown)
  (send (context-dc *ctx*) set-pen black-pen))

(define (heading)
  (context-heading *ctx*))

(define (setheading h)
  (set-context-heading! *ctx* h))

(define (setpos x y)
  (send (context-dc *ctx*) draw-line (car (pos)) (cdr (pos)) x y)  
  (set-context-pos! *ctx* (cons x y)))

(define (pos)
  (context-pos *ctx*)) 

(define (forward n)
  (let* ([xpos (car (pos))]
         [ypos (cdr (pos))]
         [head (heading)]
         [newx (inexact->exact (round (+ xpos (* n (sin (* head 0.017453292519943295))))))]
         [newy (inexact->exact (round (- ypos (* n (cos (* head 0.017453292519943295))))))])
    (setpos newx newy)))

(define (back n)
  (forward (* -1 n)))

(define (left n)
  (setheading (modulo (- (heading) n) 360)))

(define (right n)
  (setheading (modulo (+ (heading) n) 360)))

(define (clearscreen)
  (unless (context-dc *ctx*)
    (let* ([f (new frame% [label "Logo Output"])]
           [w 600]
           [h 600]
           [o (new bitmap-dc% [bitmap (make-object bitmap% w h)])]
           [c (new canvas% [parent f] [min-width w] [min-height h]
                   [paint-callback (lambda (c dc)
                                     (send dc draw-bitmap (send o get-bitmap) 0 0) 
                                     )])])
      (set-context-dc! *ctx* o)
      (set-context-canvas! *ctx* c)
      (send f show #t)))
  (send (context-dc *ctx*) clear)
  (send (context-canvas *ctx*) refresh)
  (penup)
  (setheading 0)
  (let ([b (send (context-dc *ctx*) get-bitmap)])
    (setpos (/ (send b get-width) 2)
            (/ (send b get-height) 2))))

The truly fun part is just how little a vocabulary you need to draw some fairly funky pictures. Consider the following little programs:

(define-syntax go  (syntax-rules ()
                     [(_ expr ...)
                      (begin
                        (clearscreen)
                        (pendown)
                        expr ...)]))

(define (draw-box n)
  (forward n)
  (right 90)
  (forward n)
  (right 90)
  (forward n)
  (right 90)
  (forward n))

(define (draw-boxes start-size end-size step)
  (if (> start-size end-size)
      'done
      (begin
        (draw-box start-size)
        (left 5)
        (draw-boxes (+ start-size step) end-size step))))

(define (tree size)
  (cond ((< size 5) (forward size) (back size))
        (else (forward (/ size 3))
              (left 30) (tree (* size 2/3)) (right 30)
              (back (/ size 3))
              (forward (/ size 2))
              (right 25) (tree (/ size 2)) (left 25)
              (back (/ size 2))
              (forward (* size 5/6))
              (right 25) (tree (/ size 2)) (left 25)
              (back (* size 5/6)))))

You can run them as:

 (go (draw-box 10))
 (go (draw-boxes 10 1000 15))
 (go (tree 100))

Fun stuff!