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

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

(define (string-prefix? prefix string)
  (let ((index (substring-index prefix string)))
    (and index (zero? index))))

;; Determine total amount of DICT servers
(define servers '("www.dict.org" "all.dict.org"))
(define amount-servers (length servers))

(define databases '())
(define amount-databases 0)

;; Determine level (0=server 1=database)
(define level 0)
(define default #f)

;; Setup list
(gtk "gtk_init" 'NULL 'NULL)
(define iter (gtk "gtk_server_opaque"))
(define lst (gtk "gtk_list_store_new" 1 64))
(define tree (gtk "gtk_tree_view_new_with_model" lst))
(gtk "gtk_server_connect" tree "button-press-event" tree 1)
(gtk "gtk_tree_view_set_headers_visible" tree 0)
(define sel (gtk "gtk_tree_view_get_selection" tree))
(define cell (gtk "gtk_cell_renderer_text_new"))
(define column (gtk "gtk_tree_view_column_new_with_attributes" "Server" cell "text" 0 'NULL))
(gtk "gtk_tree_view_append_column" tree column)
(gtk "gtk_tree_view_column_set_resizable" column 1)
(gtk "gtk_tree_view_column_set_clickable" column 1)
(define sw (gtk "gtk_scrolled_window_new" 'NULL 'NULL))
(gtk "gtk_scrolled_window_set_policy" sw 1 1)
(gtk "gtk_scrolled_window_set_shadow_type" sw 1)
(gtk "gtk_widget_set_size_request" sw 1 120)
(gtk "gtk_container_add" sw tree)
;; Add the servers
(let loop ((servers servers))
    (when (pair? servers)
      (gtk "gtk_list_store_append" lst iter)
      (gtk "gtk_list_store_set" lst iter 0 (car servers) -1)
      (loop (cdr servers))))
;; Setup buttons
(define back (gtk "gtk_button_new_from_stock" 'gtk-go-back))
(define about (gtk "gtk_button_new_from_stock" 'gtk-about))
(define index (gtk "gtk_button_new_from_stock" 'gtk-index))
;; Top frame
(define frame1 (gtk "gtk_frame_new" 'NULL))
(gtk "gtk_frame_set_label" frame1 "\"DICT servers \"")
(define hbox1 (gtk "gtk_hbox_new" 0 0))
(gtk "gtk_container_add" frame1 hbox1)
(gtk "gtk_container_set_border_width" hbox1 5)
(define vbox1 (gtk "gtk_vbox_new" 0 0))
(gtk "gtk_box_pack_start" vbox1 index 1 1 1)
(gtk "gtk_box_pack_start" vbox1 back 1 1 1)
(gtk "gtk_box_pack_start" vbox1 about 1 1 1)
(gtk "gtk_box_pack_start" hbox1 sw 1 1 1)
(gtk "gtk_box_pack_start" hbox1 vbox1 0 0 5)
;; Setup entry box
(define entry (gtk "gtk_entry_new"))
;; Middle frame
(define frame2 (gtk "gtk_frame_new" 'NULL))
(gtk "gtk_frame_set_label" frame2 "\" Lookup word \"")
(define hbox2 (gtk "gtk_hbox_new" 0 0))
(gtk "gtk_container_add" frame2 hbox2)
(gtk "gtk_container_set_border_width" hbox2 5)
(gtk "gtk_box_pack_start" hbox2 entry 1 1 1)
;; Setup multiline textedit
(define txtbuf (gtk "gtk_text_buffer_new" 'NULL))
(define field (gtk "gtk_text_view_new_with_buffer" txtbuf))
(gtk "gtk_text_view_set_wrap_mode" field 1)
(gtk "gtk_server_connect" field "selection-received" "selection-received")
(define tw (gtk "gtk_scrolled_window_new" 'NULL 'NULL))
(gtk "gtk_scrolled_window_set_policy" tw 2 1)
(gtk "gtk_scrolled_window_set_shadow_type" tw 1)
(gtk "gtk_container_add" tw field)
(gtk "gtk_text_view_set_editable" field 0)
(gtk "gtk_text_view_set_wrap_mode" field 2)
(define startiter (gtk "gtk_server_opaque"))
(define enditer (gtk "gtk_server_opaque"))
(gtk "gtk_server_redefine gtk_text_buffer_create_tag NONE WIDGET 5 WIDGET STRING STRING STRING NULL")
(gtk "gtk_text_buffer_create_tag" txtbuf "blue" "foreground" "blue" 'NULL)
(gtk "gtk_text_buffer_create_tag" txtbuf "green" "foreground" "DarkGreen" 'NULL)
(gtk "gtk_text_buffer_create_tag" txtbuf "red" "foreground" "red" 'NULL)
(gtk "gtk_text_buffer_create_tag" txtbuf "bold" "weight" 700 'NULL)
(gtk "gtk_server_redefine gtk_text_buffer_insert_with_tags_by_name NONE NONE 7 WIDGET WIDGET STRING LONG STRING STRING NULL")
;; Down frame
(define frame3 (gtk "gtk_frame_new" 'NULL))
(gtk "gtk_frame_set_label" frame3 "\" Results from dictionary \"")
(define hbox3 (gtk "gtk_hbox_new" 0 0))
(gtk "gtk_container_add" frame3 hbox3)
(gtk "gtk_container_set_border_width" hbox3 5)
(gtk "gtk_box_pack_start" hbox3 tw 1 1 1)
;; Main window
(define window (gtk "gtk_window_new" 0))
(gtk "gtk_window_set_title" window "\"Scheme DICT client\"")
(gtk "gtk_widget_set_size_request" window 600 450)
(gtk "gtk_window_set_position" window 1)
(gtk "gtk_window_set_icon_name" window "gdict")
(define vbox (gtk "gtk_vbox_new" 0 0))
(gtk "gtk_box_pack_start" vbox frame1 0 0 1)
(gtk "gtk_box_pack_start" vbox frame2 0 0 1)
(gtk "gtk_box_pack_start" vbox frame3 1 1 1)
(gtk "gtk_container_add" window vbox)
;; Show everything
(gtk "gtk_box_set_spacing" vbox 5)
(gtk "gtk_container_set_border_width" vbox 5)
(gtk "gtk_widget_show_all" window)
(gtk "gtk_widget_grab_focus" entry)
;; Create ABOUT button
(define gtk-server-version (gtk "gtk_server_version"))
(define scheme-version (chicken-version))
(define msg (format "'\t\t\t*** Scheme Dict Client 1.1 ***\r\rProgrammed with CHICKEN Scheme ~a and GTK-server ~a.\r\r\tVisit http://www.gtk-server.org for more Info!'"
                    scheme-version
                    gtk-server-version))
(gtk "gtk_server_redefine gtk_message_dialog_new NONE WIDGET 5 WIDGET INT INT INT STRING")
(define dialog (gtk "gtk_message_dialog_new" window 0 0 2 msg))
(gtk "gtk_window_set_title" dialog "'About this program'")
(gtk "gtk_window_set_icon_name" dialog "gdict")
(gtk "gtk_server_connect" dialog "response" "dialog-close")

(define (get-selected-row max)
  (let loop ((nr 0))
    (if (< nr max)
        (let* ((pth (gtk "gtk_tree_path_new_from_string" nr))
               (row (gtk "gtk_tree_selection_path_is_selected" sel pth)))
          (gtk "gtk_tree_path_free" pth)
          (if (not (equal? row "1"))
              (loop (+ nr 1))
              nr))
        nr)))

(define (lookup-index)
  (when (zero? level)
    (set! databases '())
    ;; Get dictionary
    (let ((nr (get-selected-row amount-servers)))
      ;; Do nothing if there is no selection
      (when (not (= nr amount-servers))
        ;; We are in the level of databases
        (set! level 1)
        ;; Clear the list
        (gtk "gtk_list_store_clear" lst)
        ;; Save the default server
        (set! default (list-ref servers nr))
        ;; Setup connection to dictionary server
        (let-values (((in out) (tcp-connect default 2628)))
          ;; Get the available databases
          (write-line "SHOW DB" out)
          (let loop ()
            (let ((line (read-line in)))
              (when (not (equal? line "250 ok"))
                (when (and (not (string-prefix? "220" line))
                           (not (string-prefix? "110" line))
                           (not (string-prefix? "." line))
                           (not (string-prefix? "--exit--" line)))
                  (gtk "gtk_list_store_append" lst iter)
                  (let ((line (format "\"~a\"" (string-translate line "\"" "'"))))
                    (gtk "gtk_list_store_set" lst iter 0 line -1))
                  (set! databases (cons (car (string-split line)) databases)))
                (loop))))
          (set! amount-databases (length databases))
          (set! databases (reverse databases))
          (write-line "QUIT" out)
          (close-output-port out)
          (close-input-port in))))))

;; Restore serverlist
(define (back-servers)
  (set! level 0)
  (gtk "gtk_list_store_clear" lst iter)
  ;; Add the servers
  (let loop ((servers servers))
    (when (pair? servers)
      (gtk "gtk_list_store_append" lst iter)
      (gtk "gtk_list_store_set" lst iter 0 (car servers) -1)
      (loop (cdr servers)))))

(define (lookup-word)
  ;; Clear textscreen
  (gtk "gtk_text_buffer_get_bounds" txtbuf startiter enditer)
  (gtk "gtk_text_buffer_delete" txtbuf startiter enditer)
  ;; Announcement
  (gtk "gtk_text_buffer_insert_with_tags_by_name" txtbuf enditer "\"Looking up word, please wait...\" -1 bold green NULL")
  ;; (gtk "gtk_server_callback update")
  (let ((txt "")
        (in #f)
        (out #f))
    (if (zero? level)
        (let ((nr (get-selected-row amount-servers)))
          ;; Do nothing if there is no selection
          (if (= nr amount-servers)
              (begin
                ;; Clear textscreen
                (gtk "gtk_text_buffer_get_bounds" txtbuf startiter enditer)
                (gtk "gtk_text_buffer_delete" txtbuf startiter enditer)
                ;; Announcement
                (gtk "gtk_text_buffer_insert_with_tags_by_name" txtbuf enditer "\"Select a dictionary or server!\" -1 bold red NULL"))
              ;; Save the search string
              (begin
                (set! txt (gtk "gtk_entry_get_text" entry))
                ;; Depending on the level refine
                (set!-values (in out) (tcp-connect (list-ref servers nr) 2628))
                (write-line (format "DEFINE * \"~a\"" txt) out))))
        (let ((nr (get-selected-row amount-databases)))
          ;; Do nothing if there is no selection
          (if (= nr amount-databases)
              (begin
                ;; Clear textscreen
                (gtk "gtk_text_buffer_get_bounds" txtbuf startiter enditer)
                (gtk "gtk_text_buffer_delete" txtbuf startiter enditer)
                ;; Announcement
                (gtk "gtk_text_buffer_insert_with_tags_by_name" txtbuf enditer "\"Select a dictionary or server!\" -1 bold red NULL"))
              ;; Save the search string
              (begin
                (set! txt (gtk "gtk_entry_get_text" entry))
                ;; Depending on the level refine
                (set!-values (in out) (tcp-connect default 2628))
                (write-line (format "DEFINE ~a \"~a\"" (list-ref databases nr) txt) out)))))
    (when (and in out)
      ;; Clear textscreen
      (gtk "gtk_text_buffer_get_bounds" txtbuf startiter enditer)
      (gtk "gtk_text_buffer_delete" txtbuf startiter enditer)
      ;; Retrieve answer and put it in textfield
      (let loop ()
        (let ((line (read-line in)))
          (when (not (eof-object? line))
            (cond
             ((string-prefix? "250 ok" line)) ; break
             ((string-prefix? "552 no match" line)
              (gtk "gtk_text_buffer_get_end_iter" txtbuf enditer)
              (gtk "gtk_text_buffer_insert_with_tags_by_name" txtbuf enditer "\"Item not found!\" -1 bold red NULL")) ; break
             ((string-prefix? "151 " line)
              (gtk "gtk_text_buffer_get_end_iter" txtbuf enditer)
              (let* ((line (string-translate line "\""))
                     (tmp (substring line (+ (string-length txt) 6))))
                (gtk "gtk_text_buffer_insert_with_tags_by_name" txtbuf enditer (format "\"~a\n\" -1 bold blue NULL" (substring tmp (+ (substring-index " " tmp) 1))))
                (gtk "gtk_text_buffer_get_end_iter" txtbuf enditer)
                (gtk "gtk_text_buffer_insert" txtbuf enditer "\"------------------------------------------\n\" -1"))
              (loop))
             ((and (not (string-prefix? "220 " line))
                   (not (string-prefix? "150 " line)))
              (gtk "gtk_text_buffer_get_end_iter" txtbuf enditer)
              (let ((line (string-translate line "\"")))
                (gtk "gtk_text_buffer_insert" txtbuf enditer (format "\"~a\n\" -1" line)))
              (loop))
             (else
              (loop))))))
      (write-line "QUIT" out)
      (flush-output out)
      (close-output-port out)
      (close-input-port in))))

;; Mainloop
(let loop ()
  (let ((event (gtk "gtk_server_callback" 'wait)))
    (when (not (equal? event window))
      (cond
       ((equal? event "dialog-close")
        (gtk "gtk_widget_destroy" dialog))
       ((equal? event about)
        (gtk "gtk_widget_show_all" dialog))
       ((equal? event dialog)
        (gtk "gtk_widget_hide" dialog))
       ((equal? event index)
        (lookup-index))
       ((equal? event back)
        (back-servers))
       ((equal? event entry)
        (lookup-word)))
      (gtk "gtk_widget_grab_focus" entry)
      (loop))))

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