(import scheme)
(import (chicken base))
(import (chicken format))
(import (chicken io))
(import (chicken platform))
(import (chicken process))
(import (chicken string))
(import gtk-server)

(define gtk-server (start-gtk-server!))
(define (gtk #!rest args) (apply gtk-send! gtk-server args))

(gtk "gtk_init" 'NULL 'NULL)
(define win (gtk "gtk_window_new" 0))
(gtk "gtk_window_set_title" win "'CHICKEN Scheme Analog Clock'")
(gtk "gtk_window_set_size_request" win 300 350)
(gtk "gtk_window_set_position" win 1)
(gtk "gtk_window_set_resizable" win 0)
(gtk "gtk_window_set_icon_name" win "clock")
;; Use async functionality, signal every second
(gtk "gtk_server_connect" win "show" "time-update")
(gtk "gtk_server_timeout" 1000 win "show")
;; Create widget to display image
(define image (gtk "gtk_image_new"))
;; Separator
(define sep (gtk "gtk_hseparator_new"))
;; About button
(define about-button (gtk "gtk_button_new_from_stock" 'gtk-about))
(gtk "gtk_widget_set_size_request" about-button 90 30)
;; Exit button
(define exit-button (gtk "gtk_button_new_from_stock" 'gtk-quit))
(gtk "gtk_widget_set_size_request" exit-button 90 30)
;; Now arrange widgets on window using boxes
(define hbox (gtk "gtk_hbox_new" 0 0))
(gtk "gtk_box_pack_start" hbox about-button 0 0 1)
(gtk "gtk_box_pack_end" hbox exit-button 0 0 1)
(define vbox (gtk "gtk_vbox_new" 0 0))
(gtk "gtk_box_pack_start" vbox image 0 0 1)
(gtk "gtk_box_pack_start" vbox sep 0 0 1)
(gtk "gtk_box_pack_end" vbox hbox 0 0 1)
(gtk "gtk_container_add" win vbox)
;; Show all widgets
(gtk "gtk_widget_show_all" win)
;; Create the canvas
(define cairo-s (gtk "cairo_image_surface_create" 'CAIRO_FORMAT_ARGB32 300 315))
(define cairo-cr (gtk "cairo_create" cairo-s))
(gtk "cairo_set_antialias" cairo-cr 'CAIRO_ANTIALIAS_BEST)
(gtk "cairo_set_source_rgba" cairo-cr 1 1 1 1)
(gtk "cairo_rectangle" cairo-cr 0 0 300 315)
(gtk "cairo_fill" cairo-cr)
(gtk "cairo_set_line_width" cairo-cr 1)
(gtk "cairo_set_source_rgba" cairo-cr 0 0 0 1)
(gtk "cairo_rectangle" cairo-cr 0 0 300 315)
(gtk "cairo_stroke" cairo-cr)
(gtk "cairo_arc" cairo-cr 150 150 140 0 6.28)
(gtk "cairo_stroke" cairo-cr)
;; Put some text on the canvas
(gtk "cairo_set_source_rgba" cairo-cr 0 0 1 1)
(gtk "cairo_select_font_face" cairo-cr "Sans" 'CAIRO_FONT_SLANT_NORMAL 'CAIRO_FONT_WEIGHT_NORMAL)
(gtk "cairo_set_font_size" cairo-cr 12)
(gtk "cairo_move_to" cairo-cr 95 305)
(gtk "cairo_show_text" cairo-cr "'Show analog time'")
;; Obtain the picture
(gtk "gtk_image_set_from_surface" image cairo-s)

;; Create about box
(define gtk-server-version (gtk "gtk_server_version"))
(define dialog (gtk "gtk_message_dialog_new" win 0 0 2 (format "'\t\t***CHICKEN Scheme Analog Clock ***\r\rCHICKEN Scheme ~a with GTK-server ~a.\r\rVisit http://www.gtk-server.org/ for more info!'" (chicken-version) gtk-server-version) "''"))
(gtk "gtk_window_set_title" dialog "'About this program'")

(define CO (vector 0 14 27 40 53 65 76 87 97 105 113 119 124 127 129 130))
(define HO (vector 0 8 17 25 33 40 47 54 59 65 69 73 76 78 79 80))

(define (capture command-string)
  (call-with-input-pipe command-string
    (lambda (in)
      (string-chomp (read-string #f in)))))

(let loop ()
  (let ((event (gtk "gtk_server_callback wait"))
        (second (string->number (capture "date +%S")))
        (minute (string->number (capture "date +%M")))
        (hour (string->number (capture "date +%H")))
        (x #f)
        (y #f))
    (cond
     ((equal? event about-button)
      (gtk "gtk_widget_show" dialog))
     ((equal? event dialog)
      (gtk "gtk_widget_hide" dialog))
     ((equal? event "time-update")
      ;; Cleanup clock
      (gtk "cairo_set_source_rgba" cairo-cr 1 1 1 1)
      (gtk "cairo_arc" cairo-cr 150 150 142 0 6.28)
      (gtk "cairo_fill" cairo-cr)
      (gtk "cairo_set_source_rgba" cairo-cr 0 0 0 1)
      (gtk "cairo_arc" cairo-cr 150 150 140 0 6.28)
      (gtk "cairo_stroke" cairo-cr)

      ;; Draw seconds pointer
      (cond
       ((< second 15)
        (set! x (+ 150 (vector-ref CO second)))
        (set! y (- 145 (vector-ref CO (- 15 second)))))
       ((< second 30)
        (set! second (- second 15))
        (set! x (+ 150 (vector-ref CO (- 15 second))))
        (set! y (+ 145 (vector-ref CO second))))
       ((< second 45)
        (set! second (- second 30))
        (set! x (- 150 (vector-ref CO second)))
        (set! y (+ 145 (vector-ref CO (- 15 second)))))
       ((< second 60)
        (set! second (- second 45))
        (set! x (- 150 (vector-ref CO (- 15 second))))
        (set! y (- 145 (vector-ref CO second)))))
      (gtk "cairo_set_line_width" cairo-cr 0.5)
      (gtk "cairo_move_to" cairo-cr 150 145)
      (gtk "cairo_line_to" cairo-cr x y)
      (gtk "cairo_stroke" cairo-cr)
      (gtk "cairo_set_line_width" cairo-cr 1)

      ;; Draw minute pointer
      (cond
       ((< minute 15)
        (set! x (+ 150 (vector-ref CO minute)))
        (set! y (- 145 (vector-ref CO (- 15 minute))))
        (gtk "cairo_move_to" cairo-cr 151 146)
        (gtk "cairo_line_to" cairo-cr x y)
        (gtk "cairo_line_to" cairo-cr 149 144)
        (gtk "cairo_line_to" cairo-cr 151 146)
        (gtk "cairo_fill" cairo-cr))
       ((< minute 30)
        (set! minute (- minute 15))
        (set! x (+ 150 (vector-ref CO (- 15 minute))))
        (set! y (+ 145 (vector-ref CO minute)))
        (gtk "cairo_move_to" cairo-cr 151 144)
        (gtk "cairo_line_to" cairo-cr x y)
        (gtk "cairo_line_to" cairo-cr 149 146)
        (gtk "cairo_line_to" cairo-cr 151 144)
        (gtk "cairo_fill" cairo-cr))
       ((< minute 45)
        (set! minute (- minute 30))
        (set! x (- 150 (vector-ref CO minute)))
        (set! y (+ 145 (vector-ref CO (- 15 minute))))
        (gtk "cairo_move_to" cairo-cr 149 144)
        (gtk "cairo_line_to" cairo-cr x y)
        (gtk "cairo_line_to" cairo-cr 151 146)
        (gtk "cairo_line_to" cairo-cr 149 144)
        (gtk "cairo_fill" cairo-cr))
       ((< minute 60)
        (set! minute (- minute 45))
        (set! x (- 150 (vector-ref CO (- 15 minute))))
        (set! y (- 145 (vector-ref CO minute)))
        (gtk "cairo_move_to" cairo-cr 151 144)
        (gtk "cairo_line_to" cairo-cr x y)
        (gtk "cairo_line_to" cairo-cr 149 146)
        (gtk "cairo_line_to" cairo-cr 151 144)
        (gtk "cairo_fill" cairo-cr)))

      ;; Draw hour pointer
      (set! minute (string->number (capture "date +%M")))
      (set! hour (- hour 1))
      (set! hour (+ (* hour 5) (/ minute 12) 5))
      (set! hour (inexact->exact (floor hour)))
      (when (> hour 60)
        (set! hour (- hour 60)))
      (cond
       ((< hour 15)
        (set! x (+ 150 (vector-ref HO hour)))
        (set! y (- 145 (vector-ref HO (- 15 hour))))
        (gtk "cairo_move_to" cairo-cr 151 146)
        (gtk "cairo_line_to" cairo-cr x y)
        (gtk "cairo_line_to" cairo-cr 149 144)
        (gtk "cairo_line_to" cairo-cr 151 146)
        (gtk "cairo_fill" cairo-cr))
       ((< hour 30)
        (set! hour (- hour 15))
        (set! x (+ 150 (vector-ref HO (- 15 hour))))
        (set! y (+ 145 (vector-ref HO hour)))
        (gtk "cairo_move_to" cairo-cr 151 144)
        (gtk "cairo_line_to" cairo-cr x y)
        (gtk "cairo_line_to" cairo-cr 149 146)
        (gtk "cairo_line_to" cairo-cr 151 144)
        (gtk "cairo_fill" cairo-cr))
       ((< hour 45)
        (set! hour (- hour 30))
        (set! x (- 150 (vector-ref HO hour)))
        (set! y (+ 145 (vector-ref HO (- 15 hour))))
        (gtk "cairo_move_to" cairo-cr 149 144)
        (gtk "cairo_line_to" cairo-cr x y)
        (gtk "cairo_line_to" cairo-cr 151 146)
        (gtk "cairo_line_to" cairo-cr 149 144)
        (gtk "cairo_fill" cairo-cr))
       ((< hour 60)
        (set! hour (- hour 45))
        (set! x (- 150 (vector-ref HO (- 15 hour))))
        (set! y (- 145 (vector-ref HO hour)))
        (gtk "cairo_move_to" cairo-cr 151 144)
        (gtk "cairo_line_to" cairo-cr x y)
        (gtk "cairo_line_to" cairo-cr 149 146)
        (gtk "cairo_line_to" cairo-cr 151 144)
        (gtk "cairo_fill" cairo-cr)))

      ;; Draw centre
      (gtk "cairo_arc" cairo-cr 150 145 8 0 6.28)
      (gtk "cairo_fill" cairo-cr)
      ;; Refresh screen
      (gtk "gtk_image_set_from_surface" image cairo-s)))
    (unless (member event (list exit-button win))
      (loop))))

;; Exit GTK
(gtk "gtk_server_exit")
(stop-gtk-server! gtk-server)