;                        ____ _     _      _              
;                       / ___| |__ (_) ___| | _____ _ __  
;                      | |   | '_ \| |/ __| |/ / _ \ '_ \ 
;                      | |___| | | | | (__|   <  __/ | | |
;                       \____|_| |_|_|\___|_|\_\___|_| |_|
;                                                         
;      _     _       _       ____                                          
;     | |   (_)_ __ | | __  / ___|_ __ __ _ _ __ ___  _ __ ___   __ _ _ __ 
;     | |   | | '_ \| |/ / | |  _| '__/ _` | '_ ` _ \| '_ ` _ \ / _` | '__|
;     | |___| | | | |   <  | |_| | | | (_| | | | | | | | | | | | (_| | |   
;     |_____|_|_| |_|_|\_\  \____|_|  \__,_|_| |_| |_|_| |_| |_|\__,_|_|   
;
;                     ____  _           _ _
;                    | __ )(_)_ __   __| (_)_ __   __ _ ___
;                    |  _ \| | '_ \ / _` | | '_ \ / _` / __|
;                    | |_) | | | | | (_| | | | | | (_| \__ \
;                    |____/|_|_| |_|\__,_|_|_| |_|\__, |___/
;                                                 |___/

;;
;; chicken-link-grammar: Scheme bindings to the link grammar parsing system
;;
;; Copyright © 2017  David Ireland. 
;; All rights reserved. 
;;
;; | --------------------------------------------------------------------- |
;; | Use of the link grammar parsing system is subject to the terms of the | 
;; | license set forth in the LICENSE file included with this software.    |
;; | This license allows free redistribution and use in source and binary  |
;; | forms, with or without modification, subject to certain conditions.   |
;; | --------------------------------------------------------------------- |                                                                       
(module link-grammar 
 *
 (import foreign chicken scheme)
 (use extras
      srfi-1
      s
      loops)

 (foreign-declare "#include \"link-grammar/link-includes.h\"")
 (foreign-declare "#include \"link-grammar/link-features.h\"")
 (foreign-declare "#include \"link-grammar/dict-api.h\"")
 (foreign-declare "#include \"link-grammar/dict-structures.h\"")

;         _____              _               _____                      
;        |  ___|__  _ __ ___(_) __ _ _ __   |_   _|   _ _ __   ___  ___ 
;        | |_ / _ \| '__/ _ \ |/ _` | '_ \    | || | | | '_ \ / _ \/ __|
;        |  _| (_) | | |  __/ | (_| | | | |   | || |_| | |_) |  __/\__ \
;        |_|  \___/|_|  \___|_|\__, |_| |_|   |_| \__, | .__/ \___||___/
;                               |___/              |___/|_|              

 (define-foreign-type parse-options* (c-pointer (struct "Parse_Options_s")))
 (define-foreign-type cmd-options*   (c-pointer (struct "Command_Options_s")))
 (define-foreign-type cost-model*    (c-pointer (struct "Cost_Model_s")))
 (define-foreign-type resources*     (c-pointer (struct "Resources_s")))
 (define-foreign-type dictionary*    (c-pointer (struct "Dictionary_s")))
 (define-foreign-type linkage*       (c-pointer (struct "Linkage_s")))
 (define-foreign-type sub-linkage*   (c-pointer (struct "Sublinkage_s")))
 (define-foreign-type sentence*      (c-pointer (struct "Sentence_s")))

 ;                      ____            _
 ;                     / ___| _   _ ___| |_ ___ _ __ ___  
 ;                     \___ \| | | / __| __/ _ \ '_ ` _ \ 
 ;                      ___) | |_| \__ \ ||  __/ | | | | |
 ;                     |____/ \__, |___/\__\___|_| |_| |_|
 ;                            |___/                       
 ;            ___       _ _   _       _ _          _   _             
 ;           |_ _|_ __ (_) |_(_) __ _| (_)______ _| |_(_) ___  _ __  
 ;            | || '_ \| | __| |/ _` | | |_  / _` | __| |/ _ \| '_ \ 
 ;            | || | | | | |_| | (_| | | |/ / (_| | |_| | (_) | | | |
 ;           |___|_| |_|_|\__|_|\__,_|_|_/___\__,_|\__|_|\___/|_| |_|
                                                                    

 (define get-version
   (foreign-lambda c-string "linkgrammar_get_version"))

 (define get-dictionary-version
   (foreign-lambda c-string "linkgrammar_get_dict_version" dictionary*))

 (define get-dictionary-locale
   (foreign-lambda c-string "linkgrammar_get_dict_locale" dictionary*))

 ;       ____  _           _               ____                 _ _       
 ;      |  _ \(_)___ _ __ | | __ _ _   _  |  _ \ ___  ___ _   _| | |_ ___ 
 ;      | | | | / __| '_ \| |/ _` | | | | | |_) / _ \/ __| | | | | __/ __|
 ;      | |_| | \__ \ |_) | | (_| | |_| | |  _ <  __/\__ \ |_| | | |_\__ \
 ;      |____/|_|___/ .__/|_|\__,_|\__, | |_| \_\___||___/\__,_|_|\__|___/
 ;                  |_|            |___/                                  

 (define NO-DISPLAY   0)
 (define MULTI-LINE   1)
 (define BRACKET-TREE 2)
 (define SINGLE-LINE  3)
 (define MAX-STYLES   3)

 (define set-display-morphology!
   (foreign-lambda void " parse_options_set_display_morphology" parse-options* int))

 (define get-display-morphology 
   (foreign-lambda int " parse_options_get_display_morphology" parse-options*))

 ;     _____                       _   _                 _ _ _             
 ;    | ____|_ __ _ __ ___  _ __  | | | | __ _ _ __   __| | (_)_ __   __ _ 
 ;    |  _| | '__| '__/ _ \| '__| | |_| |/ _` | '_ \ / _` | | | '_ \ / _` |
 ;    | |___| |  | | | (_) | |    |  _  | (_| | | | | (_| | | | | | | (_| |
 ;    |_____|_|  |_|  \___/|_|    |_| |_|\__,_|_| |_|\__,_|_|_|_| |_|\__, |
 ;                                                                   |___/ 

 (define FATAL 1)
 (define ERROR 2)
 (define WARN  3)
 (define INFO  4)
 (define DEBUG 5)
 (define TRACE 6)
 (define NONE  7)

 ;         ____                        ___        _   _                 
 ;        |  _ \ __ _ _ __ ___  ___   / _ \ _ __ | |_(_) ___  _ __  ___ 
 ;        | |_) / _` | '__/ __|/ _ \ | | | | '_ \| __| |/ _ \| '_ \/ __|
 ;        |  __/ (_| | |  \__ \  __/ | |_| | |_) | |_| | (_) | | | \__ \
 ;        |_|   \__,_|_|  |___/\___|  \___/| .__/ \__|_|\___/|_| |_|___/
 ;                                         |_|                          

 (define init-opts
   (foreign-lambda parse-options* "parse_options_create"))

 (define set-max-parse-time!
   (foreign-lambda void "parse_options_set_max_parse_time" parse-options* int))

 (define set-linkage-limit! 
   (foreign-lambda void "parse_options_set_linkage_limit" parse-options* int))

 (define set-short-length! 
   (foreign-lambda void "parse_options_set_short_length" parse-options* int))

 (define set-disjunct-cost!
   (foreign-lambda void "parse_options_set_disjunct_cost" parse-options* int))

 (define set-min-null-count!
   (foreign-lambda void "parse_options_set_min_null_count" parse-options* int))

 (define set-max-null-count!
   (foreign-lambda void "parse_options_set_max_null_count" parse-options* int))

 (define reset-resources!
   (foreign-lambda void "parse_options_reset_resources" parse-options*))

 (define resources-exhausted?
   (foreign-lambda int "parse_options_resources_exhausted" parse-options*))

 (define memory-exhausted?
   (foreign-lambda int "parse_options_memory_exhausted" parse-options*))

 (define timer-expired?
   (foreign-lambda int "parse_options_timer_expired" parse-options*))

 (define set-max-parse-time!
   (foreign-lambda void "parse_options_set_max_parse_time" parse-options* int))

 (define set-islands-ok!
   (foreign-lambda void "parse_options_set_islands_ok" parse-options* bool))

 (define set-verbosity!
   (foreign-lambda void "parse_options_set_verbosity" parse-options* int))

 (define get-verbosity
   (foreign-lambda int "parse_options_get_verbosity" parse-options*))

 (define delete-parse-options! 
   (foreign-lambda int "parse_options_delete" parse-options* ))

 ;               ____  _      _   _                              
 ;              |  _ \(_) ___| |_(_) ___  _ __   __ _ _ __ _   _ 
 ;              | | | | |/ __| __| |/ _ \| '_ \ / _` | '__| | | |
 ;              | |_| | | (__| |_| | (_) | | | | (_| | |  | |_| |
 ;              |____/|_|\___|\__|_|\___/|_| |_|\__,_|_|   \__, |
 ;                                                         |___/ 

 (define create-dictionary-with-language 
   (foreign-lambda dictionary* "dictionary_create_lang" c-string))

 (define create-default-dictionary
   (foreign-lambda dictionary* "dictionary_create_default_lang"))

 (define get-dictionary-language
   (foreign-lambda c-string "dictionary_get_lang" dictionary*))

 (define delete-dictionary!
   (foreign-lambda void "dictionary_delete" dictionary*))

 (define set-dictionary-data-dir!
   (foreign-lambda void "dictionary_set_data_dir" (const c-string))) 

 (define get-dictionary-data-dir
   (foreign-lambda c-string "dictionary_get_data_dir")) 

 (define create-dictionary-from-utf8
   (foreign-lambda dictionary* "dictionary_create_from_utf8" c-string))

 ;                 ____             _                           
 ;                / ___|  ___ _ __ | |_ ___ _ __   ___ ___  ___ 
 ;                \___ \ / _ \ '_ \| __/ _ \ '_ \ / __/ _ \/ __|
 ;                 ___) |  __/ | | | ||  __/ | | | (_|  __/\__ \
 ;                |____/ \___|_| |_|\__\___|_| |_|\___\___||___/
                                                               

 (define create-sentence
   (foreign-lambda sentence* "sentence_create" c-string dictionary*))

 (define delete-sentence!
   (foreign-lambda void "sentence_delete" sentence*))

 (define split-sentence
   (foreign-lambda int "sentence_split" sentence* parse-options*))

 (define parse-sentence 
   (foreign-lambda int "sentence_parse" sentence* parse-options*))

 (define sentence-length
   (foreign-lambda int "sentence_length" sentence*))

 (define sentence-null-count
   (foreign-lambda int "sentence_null_count" sentence*))

 (define linkages-found
   (foreign-lambda int "sentence_num_linkages_found" sentence*))

 (define valid-linkages
   (foreign-lambda int "sentence_num_valid_linkages" sentence*))

 (define linkages-post-processed 
   (foreign-lambda int "sentence_num_linkages_post_processed" sentence*))

 (define linkages-violated
   (foreign-lambda int "sentence_num_violations" sentence* int))

 (define sentence-disjunct-cost 
   (foreign-lambda int "sentence_disjunct_cost" sentence* int))

 (define sentence-link-cost
   (foreign-lambda int "sentence_link_cost" sentence* int))
                        
 ;                   _     _       _                         
 ;                  | |   (_)_ __ | | ____ _  __ _  ___  ___ 
 ;                  | |   | | '_ \| |/ / _` |/ _` |/ _ \/ __|
 ;                  | |___| | | | |   < (_| | (_| |  __/\__ \
 ;                  |_____|_|_| |_|_|\_\__,_|\__, |\___||___/
 ;                                           |___/           

 (define create-linkage
   (foreign-lambda linkage* "linkage_create" size_t sentence* parse-options*))

 (define delete-linkage! 
   (foreign-lambda void "linkage_delete" linkage*))

 (define num-words
   (foreign-lambda size_t "linkage_get_num_words" linkage*))

 (define num-links
   (foreign-lambda size_t "linkage_get_num_links" linkage*))

 (define get-lword
   (foreign-lambda size_t "linkage_get_link_lword" linkage* size_t))

 (define get-rword
   (foreign-lambda size_t "linkage_get_link_rword" linkage* size_t))

 (define link-length
   (foreign-lambda int "linkage_get_link_length" linkage* size_t))

 (define link-label
   (foreign-lambda c-string "linkage_get_link_label" linkage* size_t))

 (define link-llabel
   (foreign-lambda c-string "linkage_get_link_llabel" linkage* size_t))

 (define link-rlabel
   (foreign-lambda c-string "linkage_get_link_rlabel" linkage* size_t))

 (define num-domains
   (foreign-lambda int "linkage_get_link_num_domains" linkage* size_t))

 (define link-domain-names
     (foreign-safe-lambda* scheme-object ((linkage* links) (int index))
     "const char** words = linkage_get_link_domain_names(links, index);"
     "C_word lst = C_SCHEME_END_OF_LIST, len, str, *a;"
     "int num_words = linkage_get_link_num_domains(links, index);"
     "int i;"
     "for (i = num_words - 1; i >= 0; i--) {"
         "len = strlen(words[i]);"
         "a = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(len));"
         "str = C_string(&a, len, words[i]);"
         "lst = C_a_pair(&a, str, lst);"
     "}"
     "C_return(lst);\n"))
 
 (define get-words
    (foreign-safe-lambda* scheme-object ((linkage* links))
     "const char** words = linkage_get_words(links);"
     "C_word lst = C_SCHEME_END_OF_LIST, len, str, *a;"
     "int num_words = linkage_get_num_words(links);"
     "int i;"
     "for (i = num_words - 1; i >= 0; i--) {"
         "len = strlen(words[i]);"
         "a = C_alloc(C_SIZEOF_PAIR + C_SIZEOF_STRING(len));"
         "str = C_string(&a, len, words[i]);"
         "lst = C_a_pair(&a, str, lst);"
     "}"
     "C_return(lst);\n"))
                   
                     
 (define disjunct-str
   (foreign-lambda c-string "linkage_get_disjunct_str" linkage* size_t))

 (define disjunct-cost
   (foreign-lambda double "linkage_get_disjunct_cost" linkage* size_t))

 (define disjunct-corpus-score
   (foreign-lambda double "linkage_get_disjunct_corpus_score" linkage* size_t))

 (define get-word
   (foreign-lambda c-string "linkage_get_word" linkage* size_t))

 (define get-constituents
   (foreign-lambda c-string "linkage_print_constituent_tree" linkage* int)) 

 (define delete-constituents!
   (foreign-lambda void "linkage_free_constituent_tree_str" c-string))

 (define get-diagram
   (foreign-lambda c-string "linkage_print_diagram" linkage* bool size_t))

 (define delete-diagram
   (foreign-lambda void "linkage_free_diagram" c-string))

 (define get-postscript 
   (foreign-lambda c-string "linkage_print_postscript" linkage* bool bool))

 (define delete-postscript
   (foreign-lambda void "linkage_free_postscript" c-string))

 (define get-disjuncts 
   (foreign-lambda c-string "linkage_print_disjuncts" linkage*))

 (define delete-disjuncts
   (foreign-lambda void "linkage_free_disjuncts" c-string))

 (define get-links-domains
   (foreign-lambda c-string "linkage_print_links_and_domains" linkage*))

 (define delete-links-domains
   (foreign-lambda void "linkage_free_links_and_domains" c-string))

 (define get-pp-msgs
   (foreign-lambda c-string "linkage_print_pp_msgs" linkage*))

 (define free-pp-pmsgs
   (foreign-lambda void "linkage_free_pp_msgs" c-string))

 (define get-senses
   (foreign-lambda c-string "linkage_print_senses" linkage*))

 (define free-senses
   (foreign-lambda void "linkage_free_senses" c-string))

 (define unused-word-cost
   (foreign-lambda int "linkage_unused_word_cost" linkage*))

 (define disjunct-cost
   (foreign-lambda double "linkage_disjunct_cost" linkage*))

 (define link-cost
   (foreign-lambda int "linkage_link_cost" linkage*))

 (define corpus-cost
   (foreign-lambda double "linkage_corpus_cost" linkage*))

 (define get-violation-name
   (foreign-lambda c-string "linkage_get_violation_name" linkage*))

;     _   _           _                                       _           _ 
;    | | | |_ __   __| | ___   ___ _   _ _ __ ___   ___ _ __ | |_ ___  __| |
;    | | | | '_ \ / _` |/ _ \ / __| | | | '_ ` _ \ / _ \ '_ \| __/ _ \/ _` |
;    | |_| | | | | (_| | (_) | (__| |_| | | | | | |  __/ | | | ||  __/ (_| |
;     \___/|_| |_|\__,_|\___/ \___|\__,_|_| |_| |_|\___|_| |_|\__\___|\__,_|
;                                                                           
;                                   _    ____ ___ 
;                                  / \  |  _ \_ _|
;                                 / _ \ | |_) | | 
;                                / ___ \|  __/| | 
;                               /_/   \_\_|  |___|

(define (linkage->eps path postscript)
   (with-output-to-file path
                        (lambda ()
                          (format #t "~A~%" postscript))))

(define *DEFAULT-DICTIONARY* #f)
(define *DEFAULT-OPTS*       #f)

(define (delete-default-dictionary!)
  (delete-dictionary! *DEFAULT-DICTIONARY*))

(define (delete-default-opts!)
  (delete-parse-options! *DEFAULT-OPTS*))

(define (split-word-tags str)
  (let* ((val (s-split "." str))
         (len (length val)))
    (if (> len 1)
      (cons (car val) (cadr val))
      (cons (car val) "-"))))

(define (linkage->sexp linkage index)
  (let* ((left-index  (get-lword linkage index))
         (right-index (get-rword linkage index))
         (left        (get-word linkage left-index))
         (right       (get-word linkage right-index))
         (num-words   (num-words linkage))
         (words       (get-words linkage))
         (label       (link-label linkage index))
         (opt         (list->string
                        (filter char-upper-case?
                                (string->list label))))
         (args        (list->string
                        (filter char-lower-case? 
                                (string->list label))))
         (left-word   (split-word-tags left))
         (right-word  (split-word-tags right))
         (result     `((,opt         . ,args)
                       (,left-index  . ,(cdr  left-word ))
                       (,right-index . ,(cdr right-word)))))
    (list result)))

(define (find-linkage sentence *DEFAULT-OPTS* index)
  (let* ((links-found (linkages-found sentence))
         (linkage     (create-linkage index sentence *DEFAULT-OPTS*)))
    (if linkage
      (let* ((links        (list))
             (constituents (get-constituents linkage SINGLE-LINE))
             (diagram      (get-diagram linkage #t 100))
             (len          (num-links linkage))
             (cnt          0)
             (words        (get-words linkage)))
        (do-while (< cnt len)
                  (set! links (append links (linkage->sexp linkage cnt)))
                  (set! cnt (+ cnt 1)))
        (values (list words)
                (list links)
                (list diagram)
                (list (get-postscript linkage #t #t))))
      (values (list)
              (list)
              (list)
              (list)))))

(define (create-default-opts)
  (let ((opts (init-opts)))
    (set-linkage-limit!  opts 1000)
    (set-short-length!   opts 10)
    (set-verbosity!      opts 1)
    (set-max-parse-time! opts 30)
    (set-linkage-limit!  opts 1000)
    (set-min-null-count! opts 0)
    (set-max-null-count! opts 0)
    (set-short-length!   opts 16)
    (set-islands-ok!     opts #f)
    opts))

(define (parse text)
    (when (not *DEFAULT-DICTIONARY*)
      (set! *DEFAULT-DICTIONARY* (create-default-dictionary)))
    
    (when (not *DEFAULT-OPTS*)
      (set! *DEFAULT-OPTS* (create-default-opts)))

  (let* ((sentence     (create-sentence text *DEFAULT-DICTIONARY*))
         (num-linkages (parse-sentence sentence *DEFAULT-OPTS*)))
    (when (= num-linkages 0)
      (begin
        (set-min-null-count! *DEFAULT-OPTS*  1)
        (set-max-null-count! *DEFAULT-OPTS* (sentence-length sentence))
        (set! num-linkages (parse-sentence sentence *DEFAULT-OPTS*))))
    
    (let loop ((words       (list))
               (links       (list))
               (diagrams    (list))
               (postscripts (list))
               (index    0))
      (let-values (((w l d p) (find-linkage sentence *DEFAULT-OPTS* index)))
                  (if (>= (+ index 1) num-linkages)
                    (begin
                      (delete-sentence! sentence)
                      (values (append words       w)
                              (append links       l)
                              (append diagrams    d)
                              (append postscripts p)))
                    (loop (append words       w)
                          (append links       l)
                          (append diagrams    d)
                          (append postscripts p)
                          (+ index 1)))))))

 
) ; End of module