#!/usr/bin/sbcl --noinform
(defpackage #:generate
  (:use :cl))
(in-package #:generate)
(require 'sb-posix)
(require 'clsql)
(require 'cl-ppcre)
(require 'iconv)
(require 'babel)

;(require 'getopt)
;(defvar *options* (getopt:getopt *posix-argv* '(("style" :optional nil))))
;(print *options*)

(clsql:connect '("iso639-3.db") :database-type :sqlite3)

(defun empty-p (str)
  (eq 0 (array-dimension str 0)))

;; the data classes
(clsql:def-view-class code ()
  ((part3
    :accessor part3
    :db-kind :key
    :db-constraints (:not-null :unique)
    :type string
    :column "Id")
   (part2b
    :accessor part2b
    :type string
    :column "Part2B")
   (part2t
    :accessor part2t
    :type string
    :column "Part2T")
   (part1
    :accessor part1
    :type string
    :column "Part1")
   (scope
    :accessor scope
    :type string
    :column "Scope")
   (ltype
    :accessor ltype
    :type string
    :column "Type")
   (ref-name
    :accessor ref-name
    :type string
    :column "Ref_Name")
   (comment
    :accessor comment
    :type string
    :column "Comment")
   (names
    :accessor names
    :db-kind :join
    :db-info (:join-class code-name
              :home-key part3
              :foreign-key part3
              :set t))
   (retirement
    :accessor retirement
    :db-kind :join
    :db-info (:join-class retirement
              :home-key part3
              :foreign-key became
              :set t)))
  (:base-table "ISO_639-3"))

(clsql:def-view-class code-name ()
  ((part3
    :accessor part3
    :db-kind :key
    :column "Id")
   (print-name
    :accessor print-name
    :type string
    :column "Print_Name")
   (inverted-name
    :accessor inverted-name
    :type string
    :column "Inverted_Name"))
  (:base-table "ISO_639_3_Names"))

(clsql:def-view-class retirement ()
  ((part3
    :accessor part3
    :db-kind :key
    :type string
    :column "Id")
   (reason
    :accessor reason
    :type string
    :column "Ret_Reason")
   (became
    :accessor became
    :type string
    :column "Change_To")
   (remedy
    :accessor remedy
    :type string
    :column "Ret_Remedy")
   (date
    :accessor date
    :type string
    :column "Effective"))
  (:base-table "ISO_639_3_Retirements"))

(defun real-name (code)
  (let ((n (first (names code))))
    (if (or n (equalp '(nil) n))
        (print-name n)
        (ref-name code))))

;; data layer
(defun scan-name-of-code (regex code)
  (cl-ppcre:scan regex (ref-name code)))

(defun ancient-p (code)
  (or (equalp (ltype code) "A")
      (scan-name-of-code "Ancient" code)))
(defun constructed-p (code)
  (equalp (ltype code) "C"))
(defun extinct-p (code)
  (equalp (ltype code) "E"))
(defun historical-p (code)
  (or (equalp (ltype code) "H")
      (ancient-p code)
      (scan-name-of-code "Old|Middle" code)))
(defun living-p (code)
  (equalp (ltype code) "L"))
(defun special-p (code)
  (equalp (ltype code) "S"))
(defun individual-p (code)
  (equalp (scope code) "I"))
(defun sign-language-p (code)
  (scan-name-of-code "Sign Language" code))
(defun creole-p (code)
  (scan-name-of-code "Creole|Kriol" code))

(defun creole-language (code)
  (cl-ppcre:register-groups-bind (lang) ("Creole \(\w*\)" (ref-name code))
                                 lang))
                                 

(defun change-p (retirement)
  (equalp (reason retirement) "C"))
(defun duplicate-p (retirement)
  (equalp (reason retirement) "D"))
(defun nonexistant-p (retirement)
  (equalp (reason retirement) "N"))
(defun split-p (retirement)
  (equalp (reason retirement) "S"))
(defun merged-p (retirement)
  (equalp (reason retirement) "M"))
(defun retired-p (code)
  (not (not (retirement code))))

;; object/rule construction layer
;(defun rule (obj1 rel obj2 &optional neg) (princ (format nil "~:[~;~~~]~A ~A ~A~%" (eq t neg) obj1 rel obj2)))
;(defun quotes (str) (format nil "\"~A\"" str))
;(defun bracket (str) (format nil "[~A]" str))
;(defun stringify (str) (bracket (quotes str)))
;(defun name (n) (bracket (string-downcase n)))
;(defun ctype (tn v) (bracket (format nil "~A: ~{~A~^; ~}" tn (if (listp v) v (list v)))))
;(defun url (u) (ctype "url" (list (stringify u))))
;(defun wiki-url (l) (url (format nil "http://en.wikipedia.org/wiki/~A_language" l)))
;(defun timepoint (tstr) (ctype "timepoint" (stringify tstr)))
;(defun timeperiod (s e) (ctype "timeperiod" (list s e)))
;(defun fact-pattern (obj1 rel obj2) (ctype "fact pattern" (list obj1 rel obj2)))
;(defun temporary (n) (ctype "temporary id"
;                            (stringify (cl-ppcre:regex-replace-all "[^a-z0-9 ]"
;                                                                   (string-downcase
;                                                                    (babel:octets-to-string
;                                                                     (iconv:iconv "UTF8" "ASCII//TRANSLIT"
;                                                                                  (babel:string-to-octets n))
;                                                                     :encoding :ascii))
;                                                                   ""))))

(defun rule (obj1 rel obj2 &optional neg time) (princ (format nil "~A	~A	~A	~:[0~;1~]~@[	~A~]~%" obj1 rel obj2 neg time)))
(defun quotes (str) (format nil "\"~A\"" str))
(defun bracket (str) (format nil "[~A]" str))
(defun stringify (str) (quotes str))
(defun name (n) (string-downcase n))
(defun ctype (tn v) (format nil "~A: ~{~A~^; ~}" tn (mapcar (lambda (s) (bracket s)) (if (listp v) v (list v)))))
(defun url (u) (ctype "url" (list (quotes u))))
(defun wiki-url (l) (url (format nil "http://en.wikipedia.org/wiki/~A_language" l)))
(defun timepoint (tstr) (ctype "timepoint" (quotes tstr)))
(defun timeperiod (s e) (ctype "timeperiod" (list s e)))
(defun fact-pattern (obj1 rel obj2) (ctype "fact pattern" (list obj1 rel obj2)))
(defun temporary (n) (ctype "temporary id"
                            (quotes (cl-ppcre:regex-replace-all "[^a-z0-9 ]"
                                                                (string-downcase
                                                                 (babel:octets-to-string
                                                                  (iconv:iconv "UTF8" "ASCII//TRANSLIT"
                                                                               (babel:string-to-octets n))
                                                                  :encoding :ascii))
                                                                ""))))

;; some common objects
(defvar human-language (name "spoken form of a language"))
(defvar living-language (name "living language"))
(defvar extinct-language (name "extinct language"))
(defvar ancient-language (name "ancient language"))
(defvar historical-language (name "historical language"))
(defvar constructed-language (name "constructed language"))
(defvar sign-language (name "sign language"))
(defvar creole (name "creole"))
(defvar time-zero (name "time zero"))
(defvar iafter (name "iafter"))
(defvar unspecified-object (name "object unspecified"))
(defvar zero (stringify "0"))
(defun make-creole (lang)
  (name (format nil "~A creole" lang)))

;; common relations
(defun iso-code-for (part)
  (name (concatenate 'string "is the iso " part " code for")))

(defvar iso639-3-code-for (iso-code-for "639-3"))
(defvar retired-iso-639-3-code-for (name "is a retired iso 639-3 code for"))
(defvar iso639-2b-code-for (iso-code-for "639-2b"))
(defvar iso639-2t-code-for (iso-code-for "639-2t"))
(defvar iso639-1-code-for (iso-code-for "639-1"))
(defvar translates-as (name "commonly translates as"))
(defvar uniquely-translates-as (name "uniquely translates as"))
(defvar instance-of (name "is an instance of"))
(defvar url-for (name "is the wikipedia page for"))
(defvar can-denote (name "can denote"))
(defvar applies-for-timeperiod (name "applies for timeperiod"))
(defvar is-order-of (name "has order"))

;; multiple rules at once
;(defun rule-for-timeperiod (obj1 rel obj2 trueperiod &optional falseperiod)
;  (rule obj1 rel obj2)
;  (if trueperiod
;      (progn (rule "!-1" applies-for-timeperiod trueperiod)
;             (if falseperiod
;                 (rule "!-2" applies-for-timeperiod falseperiod t)))
;      (rule "!-1" applies-for-timeperiod falseperiod t)))

(defun rule-for-timeperiod (obj1 rel obj2 trueperiod &optional falseperiod)
  (rule obj1 rel obj2 nil trueperiod)
  (if falseperiod
      (rule obj1 rel obj2 t falseperiod)))

;; the real work
(defun generate-class-rules (code objid)
  (rule objid instance-of human-language)
  (cond ((living-p code)
         (rule objid instance-of living-language))
        ((or (extinct-p code)
             (ancient-p code)
             (historical-p code))
         (rule objid instance-of extinct-language)))
  (if (ancient-p code)
      (rule objid instance-of ancient-language))
  (if (historical-p code)
      (rule objid instance-of historical-language))
  (if (constructed-p code)
      (rule objid instance-of constructed-language))        
  (if (sign-language-p code)
      (rule objid instance-of sign-language))
  (if (creole-p code)
      (let ((lang (creole-language code)))
        (if lang
            (rule objid instance-of (make-creole lang))
            (rule objid instance-of creole)))))

(defun generate-denote-rules (code objid)
  (let ((language-name (real-name code))
        (reference-name (ref-name code)))
    (rule objid uniquely-translates-as (stringify (format nil "~A, the spoken human language" language-name)))
    (rule objid translates-as (stringify language-name))
    (rule (stringify reference-name) can-denote objid)
    (mapcar (lambda (codename)
              (let ((iname (inverted-name codename)))
                (if (not (equalp reference-name language-name))
                    (rule (stringify language-name) can-denote objid))
                (if (not (equalp iname language-name))
                    (rule (stringify iname) can-denote objid))))
            (names code))))

(defun generate-part3-rules (code objid)
  (let ((rets (retirement code))
        (main-date (timepoint "2007/2/5")))
    (if (retired-p code)
        (mapcar (lambda (ret)
                  (let ((retire-date (timepoint (date ret))))
                    (rule-for-timeperiod (stringify (part3 code)) iso639-3-code-for objid
                                         (timeperiod retire-date iafter)
                                         (timeperiod time-zero retire-date))
                    (rule-for-timeperiod (stringify (part3 ret)) iso639-3-code-for objid
                                         (timeperiod main-date retire-date)
                                         (timeperiod time-zero main-date))
                    (rule-for-timeperiod (stringify (part3 ret)) retired-iso-639-3-code-for objid
                                         (timeperiod retire-date iafter)
                                         (timeperiod time-zero retire-date))))
                rets)
        (rule-for-timeperiod (stringify (part3 code)) iso639-3-code-for objid
                             (timeperiod main-date iafter)
                             (timeperiod time-zero main-date)))))

(defun generate-other-part-rules (code objid)
  (if (not (empty-p (part2b code)))
      (rule-for-timeperiod (stringify (part2b code)) iso639-2b-code-for objid
                           (timeperiod (timepoint "1998/8/1") iafter)
                           (timeperiod time-zero (timepoint "1998/8/1")))
      (rule-for-timeperiod (fact-pattern unspecified-object iso639-2b-code-for objid) is-order-of zero
                           (timeperiod time-zero iafter)))
  (if (not (empty-p (part2t code)))
      (rule-for-timeperiod (stringify (part2t code)) iso639-2t-code-for objid
                           (timeperiod (timepoint "1998/8/1") iafter)
                           (timeperiod time-zero (timepoint "1998/8/1")))
      (rule-for-timeperiod (fact-pattern unspecified-object iso639-2t-code-for objid) is-order-of zero
                           (timeperiod time-zero iafter)))
  (if (not (empty-p (part1 code)))
      (rule-for-timeperiod (stringify (part1 code)) iso639-1-code-for objid
                           (timeperiod (timepoint "2002/1/1") iafter)
                           (timeperiod time-zero (timepoint "2002/1/1")))
      (rule-for-timeperiod (fact-pattern unspecified-object iso639-1-code-for objid) is-order-of zero
                           (timeperiod time-zero iafter))))

(defun generate-wikipedia-rules (code objid)
  (rule (wiki-url (real-name code)) url-for objid))

(defun generate-rules (code)
  (if (not (special-p code))
      (let ((objid (temporary (real-name code))))
        (generate-class-rules code objid)
        (generate-wikipedia-rules code objid)
        (generate-denote-rules code objid)
        (generate-part3-rules code objid)
        (generate-other-part-rules code objid))))

#.(clsql:locally-enable-sql-reader-syntax) 
(mapcar #'generate-rules (clsql:select 'code :flatp t
;                                       :where [= [Id] "aae"]
                                       ))
#.(clsql:restore-sql-reader-syntax-state)