#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do mq)' -s $0 "$@" #-*-scheme-*-
!#
;;; mq --- metri quadrati

;; Copyright (C) 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: mq [options] [FILENAME]
;;
;; Display an empty "floorplan" (X window) on which you can draw
;; and erase "furniture".  The scale is one pixel per centimeter,
;; with minimum size 10cm x 10cm.
;;
;; Options are [default value in square braces]:
;;
;; -g, --geometry WxH   -- Make the top-level window W by H pixels.
;;                         [800x600]
;;     --bpp N          -- Use N bits per pixel; N = 8, 16, 24, 32.
;;                         [32]  Note that alpha blending is ugly
;;                         for bpp 16, and non-existent for bpp 8.
;;
;; To draw, press and hold down the ‘c’ key, move the mouse to the
;; opposite corner of the rectangle, and release the key.  Other keys:
;;   q   -- query size (also works with in-between space)
;;   s   -- shift (move) -- hold down (like ‘c’)
;;   r   -- resize -- hold down (like ‘c’) "near" a corner
;;   x   -- erase
;;   ESC -- quit
;;
;; If FILENAME is specified, read previously-saved data from there
;; (ignoring --geometry), and save current data there on quit.

;;; Code:

(define-module (ttn-do mq)
  #:export (main)
  #:use-module ((ttn-do zzz banalities)
                #:select (check-hv qop<-args))

  #:use-module ((ttn-do zzz personally)
                #:select (FE fs whatever))

  #:use-module ((ttn-do zzz filesystem)
                #:select (safe-rewind))

  #:use-module ((ice-9 optargs-kw)
                #:select (let-optional*
                          let-keywords*
                          lambda*
                          define*))

  #:use-module ((srfi srfi-1)
                #:select (filter
                          find
                          car+cdr))

  #:use-module ((srfi srfi-11)
                #:select (let-values))

  #:use-module ((sdl sdl)
                #:prefix SDL:
                #:select (get-app-state
                          get-ticks
                          set-alpha!
                          flip
                          warp-mouse
                          make-rect
                          fill-rect
                          rect:x rect:y rect:w rect:h
                          rect:set-x! rect:set-y!
                          make-surface
                          surface:w surface:h
                          make-color
                          blit-surface
                          make-event
                          poll-event
                          pump-events
                          peep-events
                          event:type
                          event:motion:x
                          event:motion:y
                          event:key:keysym:sym))

  #:use-module ((sdl ttf)
                #:prefix TTF:
                #:select (ttf-init
                          load-font
                          font:height
                          render-text))

  #:use-module ((sdl misc-utils)
                #:select (rectangle<-geometry-string
                          rect<-surface
                          copy-rectangle
                          exact-truncate
                          ignore-all-event-types-except))

  #:use-module ((sdl gfx)
                #:prefix GFX:
                #:select (draw-rectangle
                          draw-pie-slice
                          draw-hline
                          draw-vline
                          make-fps-manager
                          fps-manager-delay!))

  #:use-module ((sdl simple)
                #:select (simple-canvas)))

(define DEFAULT-FONT-NAME
  "/usr/share/fonts/truetype/ttf-bitstream-vera/Vera.ttf")

(define FONT #f)                        ; font object
(define CANVAS #f)                      ; surface
(define ECHOAREA #f)                    ; rect
(define FOCUS? #f)

(define (fss s args)
  (let* ((text (apply simple-format #f s args))
         (surface (TTF:render-text FONT text
                                   (SDL:make-color 255 255 255)
                                   (SDL:make-color 0 0 0))))
    (values text surface)))

(define (canvas-clear! rect)
  (SDL:fill-rect CANVAS rect 0))

(define (message! s . args)
  (let-values (((text surface) (fss s args)))
    (SDL:blit-surface surface #f CANVAS ECHOAREA)
    (let ((blank-x (+ (SDL:rect:x ECHOAREA)
                      (SDL:rect:w ECHOAREA))))
      (canvas-clear! (SDL:make-rect blank-x
                                    (SDL:rect:y ECHOAREA)
                                    (- (SDL:surface:w CANVAS) blank-x)
                                    (SDL:rect:h ECHOAREA))))))

(define (rect<-2p x0 y0 x1 y1)
  (SDL:make-rect (min x0 x1)
                 (min y0 y1)
                 (1+ (abs (- x0 x1)))
                 (1+ (abs (- y0 y1)))))

(define new-location (make-object-property))

(define (opaque n)
  (logior #xff (ash n 8)))

(define BLACK (opaque #x000000))
(define WHITE (opaque #xffffff))

(define (frame! x0 y0 x1 y1 color)
  (GFX:draw-rectangle CANVAS x0 y0 x1 y1 color))

(define name (make-object-property))

(define (random-name prefix)
  (string->symbol
   (string-append prefix (number->string (random 9999999) 36))))

(define stuff
  (let ((last (SDL:get-ticks))
        (now #f)
        (todo (vector))
        (tidx (list)))

    (define (show!)
      (set! now (SDL:get-ticks))
      (cond ((or FOCUS? (< (+ 1000 last) now))
             (set! last now)
             (FE tidx (lambda (i)
                        (FE (vector-ref todo i)
                            (lambda (thunk)
                              (thunk)))))
             (SDL:flip))))

    (define* (add! level thunk #:key
                   (time-varying #f)
                   (delete-on (whatever)))
      (and time-varying
           (set! thunk (let ((thunk thunk)
                             (start (SDL:get-ticks)))
                         (define (new-thunk)
                           (thunk now))
                         new-thunk)))
      (and (not (unspecified? delete-on))
           (set! thunk (let ((thunk thunk))
                         (define (new-thunk)
                           (and (eq? delete-on (thunk))
                                (del! new-thunk)))
                         new-thunk)))
      (or (< level (vector-length todo))
          (let ((new-todo (make-vector (1+ level) '())))
            (FE tidx (lambda (i)
                       (vector-set! new-todo i (vector-ref todo i))))
            (set! todo new-todo)))
      (vector-set! todo level (append! (vector-ref todo level)
                                       (list thunk)))
      (set! tidx (iota (vector-length todo))))

    (define (del! thunk)
      (let loop ((i-ls tidx))
        (or (null? i-ls)
            (let ((ls (vector-ref todo (car i-ls))))
              (cond ((memq thunk ls)
                     (vector-set! todo (car i-ls) (delq! thunk ls)))
                    (else
                     (loop (cdr i-ls))))))))

    ;; rv
    (lambda (command . args)
      (apply (case command
               ((#:show!) show!)
               ((#:add!) add!)
               ((#:del!) del!)
               (else (error "stuff: bad command")))
             args))))

(define (show-temporarily surface rect up ok dn)
  (stuff #:add! 2 (let* ((beg (SDL:get-ticks))
                         (one (+ up beg))
                         (two (+ ok one))
                         (end (+ dn two))
                         (bye (SDL:make-surface (SDL:rect:w rect)
                                                (SDL:rect:h rect))))
                    (define (draw! tick)
                      (define (alpha! surface was denom)
                        (SDL:set-alpha! surface 'SDL_SRCALPHA
                                        (exact-truncate
                                         (* 256 (/ (- tick was)
                                                   denom)))))
                      (cond ((> one tick)
                             (alpha! surface beg up)
                             (SDL:blit-surface surface #f CANVAS rect))
                            ((> two tick)
                             (SDL:blit-surface surface #f CANVAS rect))
                            ((> end tick)
                             (alpha! bye two dn)
                             (SDL:blit-surface bye #f CANVAS rect))
                            (else
                             #:bye)))
                    (SDL:fill-rect bye #f 0)
                    draw!)
         #:time-varying #t
         #:delete-on #:bye))

(define (tmpmsg! x y s . args)
  (let-values (((text surface) (fss s args)))
    (show-temporarily surface (rect<-surface
                               surface
                               (- x (quotient (SDL:surface:w surface) 2))
                               (- y (SDL:surface:h surface) 1))
                      1000 2000 1000)))

(define (xywh rect)
  (values (SDL:rect:x rect)
          (SDL:rect:y rect)
          (SDL:rect:w rect)
          (SDL:rect:h rect)))

(define live
  (let ((wipes (make-object-property))
        (rects (list)))

    (define (add! rect wipe)
      (set! rects (cons rect rects))
      (set! (wipes rect) wipe))

    (define (collisione? a b)
      ;; Dice <http://en.wikipedia.org/wiki/Bounding_volume>:
      ;;  «For an AABB defined by M,N against one
      ;;   defined by O,P they do not intersect if
      ;;   (Mx>Px) or (Ox>Nx) or (My>Py) or (Oy>Ny).»
      (let* ((Mx (SDL:rect:x a))
             (My (SDL:rect:y a))
             (Nx (+ Mx (SDL:rect:w a) -1))
             (Ny (+ My (SDL:rect:h a) -1))
             (Ox (SDL:rect:x b))
             (Oy (SDL:rect:y b))
             (Px (+ Ox (SDL:rect:w b) -1))
             (Py (+ Oy (SDL:rect:h b) -1)))
        (not (or (> Mx Px)
                 (> Ox Nx)
                 (> My Py)
                 (> Oy Ny)))))

    (define (over x y)
      (let ((pr (SDL:make-rect x y 1 1)))
        (let loop ((ls rects))
          (cond ((null? ls) #f)
                ((collisione? (car ls) pr) (car ls))
                (else (loop (cdr ls)))))))

    (define (over-full x y)
      (let ((pr (SDL:make-rect x y 1 1))
            (ls (list)))
        (FE (reverse rects)
            (lambda (r)
              (and (collisione? r pr)
                   (set! ls (cons r ls)))))
        ls))

    (define (surrounding x y)
      (let ((L: (make-object-property))
            (R: (make-object-property))
            (T: (make-object-property))
            (B: (make-object-property)))
        (FE rects
            (lambda (rect)
              (set! (L: rect) (1- (SDL:rect:x rect)))
              (set! (R: rect) (+ (SDL:rect:x rect) (SDL:rect:w rect)))
              (set! (T: rect) (1- (SDL:rect:y rect)))
              (set! (B: rect) (+ (SDL:rect:y rect) (SDL:rect:h rect)))))
        (let ((on-x (filter (lambda (rect)
                              (<= (1+ (T: rect)) y (1- (B: rect))))
                            rects))
              (on-y (filter (lambda (rect)
                              (<= (1+ (L: rect)) x (1- (R: rect))))
                            rects)))
          (define (good coord op side ls)
            (and=> (find (lambda (rect)
                           (op coord (side rect)))
                         (sort ls (lambda (a b)
                                    (op (side a) (side b)))))
                   side))
          (let-values (((cx cy cw ch) (xywh (rect<-surface CANVAS))))
            (rect<-2p (or (good x >= R: on-x) cx)
                      (or (good y >= B: on-y) cy)
                      (or (good x <= L: on-x) (+ cx cw -1))
                      (or (good y <= T: on-y) (+ cy ch -1)))))))

    (define (surr x y)
      (or (over x y) (surrounding x y)))

    (define (del! rect)
      ((wipes rect))
      (set! (wipes rect) #f)
      (set! rects (delq! rect rects)))

    (define (dump port)
      (write (list->vector
              (map (lambda (rect)
                     (let-values (((x y w h) (xywh rect)))
                       (list x y w h)))
                   (reverse rects)))
             port)
      (newline port))

    ;; rv
    (lambda (command . args)
      (apply (case command
               ((#:add!) add!)
               ((#:over) over)
               ((#:del!) del!)
               ((#:surr) surr)
               ((#:dump) dump)
               (else (error "live: bad command")))
             args))))

(define (add-rectangle! rect)
  (let ((x0 #f) (y0 #f) (x1 #f) (y1 #f)
        (rgb (vector (random 256) (random 256) (random 256)))
        (alpha 32)
        (component (random 3)))

    (define (update-corners!)
      (let-values (((x y w h) (xywh rect)))
        (set! x0 x)
        (set! y0 y)
        (set! x1 (+ x w -1))
        (set! y1 (+ y h -1))))

    (define (draw!)
      (vector-set! rgb component
                   (let ((new-value (- (vector-ref rgb component) 3)))
                     (cond ((> 32 new-value)
                            (set! component (random 3))
                            (random 256))
                           (else new-value))))
      (and=> (new-location rect)
             (lambda (loc)
               (set! alpha
                     (if (pair? loc)
                         (let-values (((nx ny) (car+cdr loc)))
                           (cond ((or (not (= nx (SDL:rect:x rect)))
                                      (not (= ny (SDL:rect:y rect))))
                                  (canvas-clear! (copy-rectangle rect))
                                  (SDL:rect:set-x! rect nx)
                                  (SDL:rect:set-y! rect ny)
                                  (update-corners!)))
                           255)
                         (begin
                           (set! (new-location rect) #f)
                           32)))))
      (GFX:draw-rectangle
       CANVAS x0 y0 x1 y1 (logior (ash (vector-ref rgb 0) 24)
                                  (ash (vector-ref rgb 1) 16)
                                  (ash (vector-ref rgb 2) 8)
                                  alpha)
       #t))

    (update-corners!)
    (set! (name rect) (random-name "rect-"))
    (live #:add! rect (lambda ()
                        (canvas-clear! rect)
                        (stuff #:del! draw!)))
    (stuff #:add! 1 draw!)))

(define (white-cross-hair! rect mx my)
  (let-values (((x0 y0 w h) (xywh rect)))
    (let ((beg (SDL:get-ticks))
          (color #xffffffff)
          (x1 (+ x0 w -1))
          (y1 (+ y0 h -1)))
      (define (draw!)
        (GFX:draw-pie-slice CANVAS x0 my 15 -25  25 color #t)
        (GFX:draw-pie-slice CANVAS x1 my 15 155 205 color #t)
        (GFX:draw-pie-slice CANVAS mx y0 15  65 115 color #t)
        (GFX:draw-pie-slice CANVAS mx y1 15 245 295 color #t)
        (GFX:draw-hline CANVAS x0 x1 my color)
        (GFX:draw-vline CANVAS mx y0 y1 color))
      (stuff #:add! 1 (lambda (tick)
                        (draw!)
                        (let ((diff (- tick beg)))
                          (cond ((> 1000 diff))
                                ((> 2000 diff) (set! color BLACK))
                                (else #:bye))))
             #:time-varying #t
             #:delete-on #:bye))))

(define (message-area! x y)
  (message! "(~A cm x ~A cm) ~A mq"
            x y (/ (exact->inexact (* x y))
                   10000)))

(define (from-2p x0 y0)
  (let ((x1 x0)
        (y1 y0))
    (define (get-x1) x1)
    (define (get-y1) y1)
    (define (hide!)
      (frame! x0 y0 (get-x1) (get-y1) BLACK))
    (define (show!)
      (frame! x0 y0 (get-x1) (get-y1) WHITE))

    (stuff #:add! 2 show!)
    (lambda (mid? x y)
      (cond (mid?
             (hide!)
             (set! x1 x)
             (set! y1 y)
             (message-area! (1+ (abs (- x x0)))
                            (1+ (abs (- y y0)))))
            (else
             (stuff #:del! show!)
             (let ((rect (rect<-2p x0 y0 (get-x1) (get-y1))))
               (cond ((or (> 10 (SDL:rect:w rect))
                          (> 10 (SDL:rect:h rect)))
                      (hide!)
                      (message! "too small"))
                     (else
                      (add-rectangle! rect))))
             #f)))))

(define (xy rect)
  (values (SDL:rect:x rect)
          (SDL:rect:y rect)))

(define (go! p qop)
  (ignore-all-event-types-except 'SDL_ACTIVEEVENT
                                 'SDL_MOUSEMOTION
                                 'SDL_KEYDOWN
                                 'SDL_KEYUP)
  (SDL:warp-mouse 100 100)
  (set! FOCUS? (memq 'mousefocus (SDL:get-app-state)))
  (and=> (and p (false-if-exception (vector->list (read p))))
         (lambda (ls)
           (FE ls (lambda (coords)
                    (add-rectangle! (apply SDL:make-rect coords))))))
  (let ((fps (GFX:make-fps-manager 20))
        (ev (SDL:make-event))
        (newroom #f)
        (replace #f)
        (moving #f)
        (mx 0)
        (my 0))
    (let loop ()
      (cond ((not FOCUS?)
             (and (SDL:poll-event ev)
                  (eq? 'SDL_ACTIVEEVENT (SDL:event:type ev))
                  (set! FOCUS? (memq 'mousefocus (SDL:get-app-state)))))
            ((SDL:poll-event ev)
             (case (SDL:event:type ev)
               ((SDL_MOUSEMOTION)
                (set! mx (SDL:event:motion:x ev))
                (set! my (SDL:event:motion:y ev))
                (SDL:pump-events)
                (let accumulate-more-mouse-motion ()
                  (define (peep n command)
                    (SDL:peep-events #f n command '(SDL_MOUSEMOTIONMASK)))
                  (let ((avail (peep 5 'SDL_PEEKEVENT)))
                    (cond ((zero? avail))
                          ((= 1 avail)
                           (let ((bye (car (peep avail 'SDL_GETEVENT))))
                             (set! mx (SDL:event:motion:x bye))
                             (set! my (SDL:event:motion:y bye)))
                           (accumulate-more-mouse-motion))
                          (else
                           (peep avail 'SDL_GETEVENT)
                           (accumulate-more-mouse-motion)))))
                (cond (moving (let-values (((rect ox oy) moving))
                                (let ((pair (new-location rect)))
                                  (set-car! pair (- mx ox))
                                  (set-cdr! pair (- my oy))
                                  (message! "~A" pair))))
                      (newroom (newroom #t mx my))))
               ((SDL_KEYDOWN)
                (case (SDL:event:key:keysym:sym ev)
                  ((SDLK_ESCAPE)
                   (set! ev #f))
                  ((SDLK_r)
                   (and=> (and (not newroom)
                               (live #:over mx my))
                          (lambda (rect)
                            (let-values (((x y w h) (xywh rect)))
                              (let* ((r (+ x w -1))
                                     (b (+ y h -1))
                                     (x/2 (ash (+ x r) -1))
                                     (y/2 (ash (+ y b) -1))
                                     (sx (if (< x/2 mx) x r))
                                     (sy (if (< y/2 my) y b))
                                     (wx (if (eq? x sx) r x))
                                     (wy (if (eq? y sy) b y)))
                                (cond ((> 42 (sqrt (+ (expt (- wx mx) 2)
                                                      (expt (- wy my) 2))))
                                       (set! newroom (from-2p sx sy))
                                       (SDL:warp-mouse wx wy)
                                       (newroom #t wx wy)
                                       (set! replace rect))))))))
                  ((SDLK_c)
                   (or newroom (set! newroom (from-2p mx my))))
                  ((SDLK_s)
                   (and=> (live #:over mx my)
                          (lambda (rect)
                            (let-values (((x y) (xy rect)))
                              (set! moving (values rect (- mx x) (- my y)))
                              (set! (new-location rect) (cons x y))))))
                  ((SDLK_x)
                   (and=> (live #:over mx my)
                          (lambda (rect)
                            (live #:del! rect))))
                  ((SDLK_q)
                   (let ((rect (live #:surr mx my)))
                     (white-cross-hair! rect mx my)
                     (let ((w (SDL:rect:w rect))
                           (h (SDL:rect:h rect)))
                       (message-area! w h)
                       (tmpmsg! mx my " ~A x ~A " w h))))
                  (else
                   (message! "ignored: KEYDOWN ~S"
                             (SDL:event:key:keysym:sym ev)))))
               ((SDL_KEYUP)
                (case (SDL:event:key:keysym:sym ev)
                  ((SDLK_r)
                   (and replace (begin (set! newroom (newroom #f mx my))
                                       (live #:del! replace)
                                       (set! replace #f))))
                  ((SDLK_c)
                   (and newroom (set! newroom (newroom #f mx my))))
                  ((SDLK_s)
                   (and moving
                        (let-values (((rect . ignored) moving))
                          (let-values (((x y w h) (xywh rect)))
                            (message! "(~A, ~A) ~A x ~A" x y w h))
                          (set! (new-location rect) 'stop)
                          (set! moving #f))))
                  ))
               ((SDL_ACTIVEEVENT)
                (set! FOCUS? (memq 'mousefocus (SDL:get-app-state))))
               (else
                (error "unhandled event:" (SDL:event:type ev))))))
      (stuff #:show!)
      (GFX:fps-manager-delay! fps)
      (and ev (loop))))
  (and p (begin
           (safe-rewind p)
           (display (fs "\"~Ax~A\"~%"
                        (SDL:surface:w CANVAS)
                        (SDL:surface:h CANVAS))
                    p)
           (live #:dump p)
           (truncate-file p)
           (close-port p)))
  #t)

(define (main/qop qop)
  (let* ((p (false-if-exception (open-file (car (qop '())) "r+")))
         (geom (rectangle<-geometry-string
                (or (false-if-exception
                     (and=> (read p)
                            (lambda (x)
                              (and (not (eof-object? x))
                                   x))))
                    (qop 'geometry)
                    "800x600")))
         (w (SDL:rect:w geom))
         (h (SDL:rect:h geom)))
    (set! CANVAS ((simple-canvas
                   #t w h (or (qop 'bpp string->number)
                              32))))
    (TTF:ttf-init)
    (set! FONT (TTF:load-font DEFAULT-FONT-NAME 24))
    (let ((fh (TTF:font:height FONT)))
      (set! ECHOAREA (SDL:make-rect 10 (- h fh 10) (- w 10) fh)))
    (stuff #:add! 0 (let ((x1 (1- (SDL:surface:w CANVAS)))
                          (y1 (1- (SDL:surface:h CANVAS))))
                      (lambda ()
                        (frame! 0 0 x1 y1 (opaque (random #x1000000))))))
    (go! p qop)))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "1.1")
                   (help . commentary)))
  (main/qop
   (qop<-args
    args '((bpp (value #t))
           (geometry (single-char #\g) (value #t))))))

;;; mq ends here