;; The contents of this demo file are made available under the CC0 1.0
;; Universal Public Domain Dedication. See LICENSE-CC0.txt or visit
;; http://creativecommons.org/publicdomain/zero/1.0/


;; This is a demo program showing how to create and use different
;; kinds of cursors in chicken-sdl2.


(cond-expand
 (chicken-4
  (use srfi-4
       (prefix sdl2 sdl2:)))
 (chicken-5
  (import (chicken bitwise)
          (chicken condition)
          (chicken format)
          (srfi 4)
          (prefix sdl2 sdl2:))))


;;; Initialize the parts of SDL that we need.
(sdl2:set-main-ready!)
(sdl2:init! '(video events))

;; Automatically call sdl2:quit! when program exits normally.
(on-exit sdl2:quit!)

;; Call sdl2:quit! and then call the original exception handler if an
;; unhandled exception reaches the top level.
(current-exception-handler
 (let ((original-handler (current-exception-handler)))
   (lambda (exception)
     (sdl2:quit!)
     (original-handler exception))))

(define window
  (sdl2:create-window! "Cursors" 'centered 'centered  800 600))

(sdl2:fill-rect! (sdl2:window-surface window) #f
                 (sdl2:make-color 0 80 160))
(sdl2:update-window-surface! window)

(define (title! title)
  (sdl2:window-title-set!
   window
   (string-append title "  -  Click for next cursor")))

(define (wait-for-click!)
  (let ((ev (sdl2:wait-event!)))
    (case (sdl2:event-type ev)
      ((quit) (exit))
      ((mouse-button-down)
       (case (sdl2:mouse-button-event-button ev)
         ((left) #t)
         (else (wait-for-click!))))
      (else (wait-for-click!)))))


;;; CURSOR

(define smile-data
  '("           ..........           "
    "        ...@@@@@@@@@@...        "
    "       .@@@@@@@@@@@@@@@@.       "
    "     ..@@@@@@@@@@@@@@@@@@..     "
    "    .@@@@@@@@@@@@@@@@@@@@@@.    "
    "   .@@@@@@@@@@@@@@@@@@@@@@@@.   "
    "   .@@@@@@@@@@@@@@@@@@@@@@@@.   "
    "  .@@@@@@@@@@@@@@@@@@@@@@@@@@.  "
    " .@@@@@@@@@@@@@@@@@@@@@@@@@@@@. "
    " .@@@@@@@...@@@@@@@@...@@@@@@@. "
    " .@@@@@@.....@@@@@@.....@@@@@@. "
    ".@@@@@@..@@@..@@@@..@@@..@@@@@@."
    ".@@@@@@.@@@@@.@@@@.@@@@@.@@@@@@."
    ".@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@."
    ".@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@."
    ".@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@."
    ".@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@."
    ".@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@."
    ".@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@."
    ".@@@@@....................@@@@@."
    ".@@@@@.@@@.@@@@@.@@@@.@@@.@@@@@."
    " .@@@@..@@.@@@@@.@@@@.@@..@@@@. "
    " .@@@@@.@@.@@@@@.@@@@.@@.@@@@@. "
    " .@@@@@@.@.@@@@@.@@@@.@.@@@@@@. "
    "  .@@@@@@...@@@@.@@@...@@@@@@.  "
    "   .@@@@@@@..........@@@@@@@.   "
    "   .@@@@@@@@@@@@@@@@@@@@@@@@.   "
    "    .@@@@@@@@@@@@@@@@@@@@@@.    "
    "     ..@@@@@@@@@@@@@@@@@@..     "
    "       .@@@@@@@@@@@@@@@@.       "
    "        ...@@@@@@@@@@...        "
    "           ..........           "))

;;; Create cursor from list of strings, similar to an XPM image.
;;; Image width (string lengths) must be divisible by 8.
(define (make-xpm-cursor strings hot-x hot-y)
  (define (shift! u8v i n)
    (u8vector-set! u8v i (arithmetic-shift (u8vector-ref u8v i) n)))
  (define (ior! u8v i n)
    (u8vector-set! u8v i (bitwise-ior (u8vector-ref u8v i) n)))

  (assert (zero? (modulo (string-length (car strings)) 8)))

  (let* ((i -1)
         (nrows (length strings))
         (ncols (string-length (car strings)))
         (data (make-u8vector (* (/ ncols 8) nrows) 0))
         (mask (make-u8vector (* (/ ncols 8) nrows) 0)))
    (do ((row 0 (add1 row)))
        ((= row nrows))
      (do ((col 0 (add1 col)))
          ((= col ncols))
        (if (< 0 (modulo col 8))
            (begin (shift! data i 1)
                   (shift! mask i 1))
            (set! i (add1 i)))
        (case (string-ref (list-ref strings row) col)
          ((#\@)
           (ior! data i #x01)
           (ior! mask i #x01))
          ((#\.)
           (ior! mask i #x01))
          ((#\space)))))
    (sdl2:create-cursor data mask ncols nrows hot-x hot-y)))


(define xpm-cursor (make-xpm-cursor smile-data 16 16) )
(sdl2:cursor-set! xpm-cursor)
(title! "(sdl2:create-cursor ...)")
(wait-for-click!)


;;; COLOR CURSOR

(define surf (sdl2:load-bmp "face-smile.bmp"))
(define surf-large (sdl2:make-surface 64 64 24))
(sdl2:blit-scaled! surf #f surf-large #f)
(sdl2:surface-color-key-set! surf-large (sdl2:surface-ref surf 0 0))

(define surf-cursor (sdl2:create-color-cursor surf-large 32 32))
(sdl2:cursor-set! surf-cursor)
(title! "(sdl2:create-color-cursor ...)")
(wait-for-click!)


;;; SYSTEM CURSORS

(define (do-system-cursor id)
  (let ((cursor (sdl2:create-system-cursor id)))
    (sdl2:cursor-set! cursor)
    (title! (sprintf "(sdl2:create-system-cursor '~A)" id))
    (wait-for-click!)
    (sdl2:cursor-set! (sdl2:get-default-cursor))))

(for-each do-system-cursor
          '(arrow ibeam wait crosshair wait-arrow
                  size-nwse size-nesw size-we size-ns size-all
                  no hand))