;; srd-import.lisp --- Part of srd-tools

;; Copyright (C) 2008 Clinton Ebadi <clinton@unknownlamer.org>

;; Author: Clinton Ebadi <clinton@unknownlamer.org>

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


(in-package :org.unknownlamer.dnd-tools.srd-import)

;;; hack!
(setf cxml:*catalog* (cxml:make-catalog))

;;; Regex Scanners

(defparameter *spell-level-scanner*
  (create-scanner
   '(:greedy-repetition 1 nil
     (:sequence
      (:register (:sequence :word-boundary
			    (:greedy-repetition 3 nil :word-char-class)
			    :word-boundary))
      #\space
      (:register (:greedy-repetition 1 2 :digit-class))))))

(defparameter *spell-components-scanner*
  (create-scanner
   (let ((spell-component-pattern
	  '(:register (:greedy-repetition 1 2 :word-char-class))))
     `(:greedy-repetition 1 nil
			  (:sequence
			   (:alternation :word-boundary :start-anchor)
			   ,spell-component-pattern
			   (:alternation
			    (:sequence "/" ,spell-component-pattern)
			    :word-boundary)
			   (:alternation
			    (:register " (Brd only)")
			    ""))))))

(defparameter *spell-see-text-scanner*
  (create-scanner
   '(:sequence "; see text" :end-anchor)))

(let ((school-modifiers-pattern
       '(:sequence
	 (:greedy-repetition 1 nil (:char-class
				    #\-
				    :word-char-class))
	 (:alternation :word-boundary ", " " or "))))
  (defparameter *spell-school-scanner*
    (create-scanner
     `(:sequence
       :start-anchor
       (:register (:greedy-repetition 1 nil :word-char-class))
       (:alternation
	(:sequence #\space
		   #\(
		   (:register (:greedy-repetition 1 nil
						  (:char-class :word-char-class
							       #\space
							       #\,)))
		   #\))
	:end-anchor
	"")
       (:alternation
	(:sequence #\space
		   #\[
		   (:alternation
		    (:register
		     (:greedy-repetition 1 nil
					 ,school-modifiers-pattern))
		    (:sequence (:register "see text")
			       (:alternation
				""
				(:sequence
				 #\space
				 (:register (:greedy-repetition 0 nil :everything))))))
		   #\])
	:end-anchor))))

  (defparameter *spell-subschool-scanner*
    (create-scanner
     '(:sequence
       (:register (:greedy-repetition 1 nil :word-char-class))
       (:alternation
	:end-anchor
	(:sequence " or "
	 (:register (:greedy-repetition 1 nil :word-char-class)))
	(:sequence ", "
	 (:register (:greedy-repetition 1 nil :word-char-class)))))))
  
  
  (defparameter *spell-school-modifiers-scanner*
    (create-scanner
     '(:sequence
       (:register (:greedy-repetition 1 nil (:char-class
					     #\-
					     :word-char-class)))
       (:alternation
	(:sequence " or " (:register
			   (:greedy-repetition 1 nil (:char-class
						      #\-
						      :word-char-class))))
	:word-boundary
	", ")))))


(defparameter *spell-resistance-scanner*
  (create-scanner
   '(:sequence
     :start-anchor
     (:register (:greedy-repetition 2 3 :word-char-class))
     (:alternation
      (:sequence #\space
       #\(
       (:register (:greedy-repetition 1 nil :word-char-class))
       #\))
      :end-anchor))))

(defparameter *spell-saving-throw-scanner*
  (create-scanner
   '(:sequence
     :start-anchor
     (:register (:greedy-repetition 1 nil :word-char-class))
     (:alternation
      (:sequence #\space (:register (:greedy-repetition 1 nil :word-char-class)))
      :end-anchor
      "")
     (:alternation
      (:sequence #\space
       #\(
       (:register (:greedy-repetition 1 nil :word-char-class))
       #\))
      :end-anchor))))

;;; Spell component parsers

(defun parse-spell-level (spell-level-string)
  (let ((caster-levels 
	 ;; Yucky and imperative--alas, there is no map-register-groups
	 (let ((levels (list)))
	   (do-register-groups (class level)
	       (*spell-level-scanner* spell-level-string (nreverse levels))
	     (push (cons class (parse-integer level)) levels))))
	(class-abbreviations '(("Brd" . bard)
			       ("Clr" . cleric)
			       ("Drd" . druid)
			       ("Pal" . paladin)
			       ("Rgr" . ranger)
			       ("Wiz" . wizard))))
    (let ((parsed-levels
	   (mapcar (lambda (spell-level)
		     (cons (or (cdr (assoc (car spell-level) class-abbreviations :test #'string=))
			       (intern (string-upcase (car spell-level))
				       :org.unknownlamer.dnd-tools.db.symbols))
		    
			   (cdr spell-level)))
	    
		   caster-levels)))
      `(,@(if-bind classes
		   (remove-if-not (lambda (e)
				(member (car e) class-abbreviations :key #'cdr))
			      parsed-levels)
		   `((:classes . ,classes)))
	  ,@(if-bind domains (remove-if (lambda (e)
					      (member (car e) class-abbreviations :key #'cdr))
					    parsed-levels)
		   `((:domains . ,domains)))))))

(defun parse-spell-components (spell-components-string)
  (let ((spell-components
	 (let ((components (list)))
	   (do-register-groups (component divine-alternative bard?)
	       (*spell-components-scanner*
		spell-components-string
		(nreverse components))
	     (cond (divine-alternative
		    (push (list :divine-alternative
				component divine-alternative) components))
		   (bard? (if (string= component "V")
			      (push "BV" components)
			      (error "Unknown bard only component: ~A" component)))
		   (t (push component components))))))
	(srd-abbreviations '(("V" . verbal)
			     ("BV" . bard-verbal)
			     ("S" . somatic)
			     ("M" . material)
			     ("F" . focus)
			     ("DF" . divine-focus)
			     ("XP" . xp-cost))))
    (append
     (mapcar (lambda (component)
	       (flet ((component-name->symbol (name)
			(cdr (assoc name srd-abbreviations :test #'string=))))
		 (if (consp component)
		     (ecase (car component)
		       (:divine-alternative
			(list :divine-alternative
			      (component-name->symbol (second component))
			      (component-name->symbol (third component)))))
		     (component-name->symbol component))))
	     spell-components)
     (if (scan *spell-see-text-scanner* spell-components-string)
	 (list :see-text)))))

(defun parse-spell-school (spell-school-string)
  (register-groups-bind (school subschool type see-text? where)
      (*spell-school-scanner* spell-school-string)
    (destructuring-bind (school subschool (&rest modifiers) (&rest see-text))
	(mapcar (lambda (component)
		  (labels
		      ((local-intern (n)
			 (typecase n
			   (string (intern (string-upcase n)
					   :org.unknownlamer.dnd-tools.db.symbols))
			   (cons (mapcar #'local-intern n))
			   (t n))))
		    (local-intern component)))
		(list school
		      (if subschool
			  (multiple-value-bind (s groups)
			      (scan-to-strings *spell-subschool-scanner*
						     subschool)
			    (declare (ignore s))
			    (coerce groups 'list)))
		      (let ((result (list))) ; lack of map-register-groups ...
			(do-register-groups (modifier alternative)
			    (*spell-school-modifiers-scanner* type)
			  (push (if alternative
				    (list :or modifier alternative)
				    modifier)
				result))
			result)
		      (list see-text? where)))
      `((:school . ,school)
	,@(if subschool
	      `((:subschool . ,(first subschool))
		,(if (second subschool)
		     `(:alternative-subschool . ,(second subschool)))
		,(if (third subschool)
		     `(:additional-subschool . ,(third subschool)))))
	,@(cond (modifiers
		 (let ((alignments '(good chaotic lawful evil)))
		   (list
		    (if-bind alignment
			(remove-if-not (lambda (item) (member item alignments))
				       modifiers)
		      `(:alignment . ,(car alignment)))
		    (if-bind other
			(remove-if (lambda (item) (member item alignments))
				   modifiers)
		      `(:modifiers . ,other))))))
	,@(if (car see-text) `((:see-text . ,(or (cadr see-text) t))))))))


(defun parse-spell-resistance (spell-resistance-string)
  (register-groups-bind (resistance type)
      (*spell-resistance-scanner* spell-resistance-string)
    (mapcar (lambda (string) (if string (intern (string-upcase string))))
	    (list resistance type))))

(defun parse-spell-saving-throw (saving-throw-string)
  (register-groups-bind (saving-throw modifier target/type)
      (*spell-saving-throw-scanner* saving-throw-string)
    (mapcar (lambda (string) (if string (intern (string-upcase string))))
	    (list saving-throw modifier target/type))))

;;; Initial Parsing Helpers

(defun table-stp->alist (table-stp)
  (stp:map-children 'list
		    (lambda (row)
		      (cons (intern
			     (substitute
			      #\- #\space
			      (string-upcase
			       (string-right-trim
				":"
				(stp:string-value (stp:nth-child 0 row)))))
			     'keyword)
			    (stp:string-value (stp:nth-child 1 row))))
		    table-stp))

(defun spell-table-ref (item table)
  (cdr (assoc item table)))

;;; Main spell scraper

(defun scrape-spell (spell-file)
  (let ((spell-document
	 (cxml:parse-file spell-file
			  (cxml:make-whitespace-normalizer
			   (stp:make-builder)))))
    (let ((spell-elements
	   (stp:filter-children
	    (lambda (node)
	      (not (or (equalp (stp:attribute-value node "id") "header")
		       (equalp (stp:attribute-value node "class") "footer")
		       (equalp (stp:attribute-value node "class") "right"))))
	    
	    (stp:find-child-if (lambda (node) (string= "body" (stp:local-name node)))
			       (stp:document-element spell-document)))))
      (append
       (table-stp->alist (aref spell-elements 2))
       (list (cons :name (stp:string-value (aref spell-elements 0)))
	     (cons :school (stp:string-value (aref spell-elements 1)))
	     (cons :description
		   (string-trim '(#\space #\newline #\tab)
				(stp:string-value (aref spell-elements 3)))))))))

(defun parse-scraped-spell (scraped-spell)
  (let ((spell-component-parsers `((:school . ,#'parse-spell-school)
				   (:level . ,#'parse-spell-level)
				   (:components . ,#'parse-spell-components))))
    (append (mapcar (lambda (parser-key)
		      (if-bind spell-data
			  (cdr (assoc (car parser-key) scraped-spell))
			(cons (car parser-key)
			      (funcall (cdr parser-key) spell-data))))
		    spell-component-parsers)
	    (remove-if (lambda (spell-entry) (member (car spell-entry)
						spell-component-parsers
						:key #'car))
		       scraped-spell))))

(defmacro assoc-bind ((&rest binds) alist (&rest assoc-options) &body body)
  (with-unique-names (alist-var)
    (flet ((assoc-call (key)
	     `(assoc ,key ,alist-var ,@assoc-options)))
      `(let ((,alist-var ,alist))
	 (let ,(mapcar (lambda (bind)
			 `(,(first bind) ,(assoc-call (second bind))))
		       binds)
	   ,@body)))))

(defun parsed-spell->spell-object (parsed-spell)
  (assoc-bind ((school :school)
	       (levels :level)
	       (components :components)
	       (casting-time :casting-time)
	       (range :range)
	       (effect :effect)
	       (duration :duration)
	       (saving-throw :saving-throw)
	       (resistance :spell-resistance)
	       (name :name)
	       (description :description))
      parsed-spell ()
    (let ((spell-school
	   (find-spell-school (spell-table-ref :school (cdr school))
			      (spell-table-ref :subschool (cdr school))))
	  (alt-spell-school
	   (cond ((spell-table-ref :alternative-subschool (cdr school))
		  (cons :alternative
			(find-spell-school
			 (spell-table-ref :school (cdr school))
			 (spell-table-ref :alternative-subschool (cdr school)))))
		 ((spell-table-ref :additional-subschool (cdr school))
		  (cons :additional
			(find-spell-school
			 (spell-table-ref :school (cdr school))
			 (spell-table-ref :additional-subschool (cdr school)))))))
	  (spell-descriptors
	   (mapcar (lambda (d)
		     (typecase d
		       (symbol (find-spell-descriptor d))
		       (cons (find-alternate-descriptor
			      (find-spell-descriptor (second d))
			      (find-spell-descriptor (third d))
			      :create t))))
		   (spell-table-ref :modifiers (cdr school))))
	  (spell-alignment (spell-table-ref :alignment (cdr school)))
	  (spell-levels (mapcar (lambda (l) (find-spell-level (car l) (cdr l)))
				(spell-table-ref :classes (cdr levels))))
	  (spell-domains (mapcar (lambda (l) (find-spell-domain-level (car l) (cdr l)))
				 (spell-table-ref :domains (cdr levels))))
	  (spell-components
	   (mapcar (lambda (c) (cond ((symbolp c)
				 (find-spell-component c))
				((and (consp c) (eq (car c) :divine-alternative))
				 (find-spell-component (second c)))
				(t (error "Unknown spell component: ~A" c))))
		   (cdr components)))
	  (divine-alternatives (mapcar (lambda (c)
					 (cons (find-spell-component (second c))
					       (find-spell-component (third c))))
				       (remove-if-not
					(lambda (c)
					  (and (consp c)
					       (eq (car c) :divine-alternative)))
					(cdr components)))))
      (make-instance 'spell
		     :name (cdr name)
		     :levels (make-pset :items (append spell-levels spell-domains))
		     :school (if alt-spell-school
				 (find-compound-subschool
				  spell-school (cdr alt-spell-school)
				  (car alt-spell-school) :create t)
				 spell-school)
		     :alignment (or spell-alignment 'neutral)
		     :descriptors (if spell-descriptors
				      (make-pset :items spell-descriptors))
		     :components (make-pset :items spell-components)
		     :divine-alternatives (if divine-alternatives
					      (make-pset :items divine-alternatives))
		     :casting-time (cdr casting-time)
		     :range (cdr range)
		     :effect (cdr effect)
		     :duration (cdr duration)
		     :saving-throw (cdr saving-throw)
		     :resistance (cdr resistance)
		     :description (cdr description)))))

(defun scrape-spell-directory (directory-path)
  (delete nil ; filter failed spell files that are not really spells
	  (mapcar (lambda (spell-filename)
		    (ignore-errors (scrape-spell spell-filename)))
		  (fad:list-directory directory-path))))

(defun parse-scraped-spells (scraped-spells)
  (mapcar #'parse-scraped-spell scraped-spells))

(defun import-parsed-spells (parsed-spells)
  (elephant::with-batch-transaction (spells 50 parsed-spells
					    :store-controller dnd-db:*db-store*)
	     (mapcar #'parsed-spell->spell-object spells)))