cl-deck-builder2/src/models/ygoprodeck-json.lisp

#|

src/models/ygoprodeck.json.lisp

Version 3 JSON Importer

TODO Write a test suite - it should be easier now that it's in FNF

The idea behind this code is you'll be able to one click button download and update the db.

    (cl-deck-builder2.models.ygoprodeck.json2::json-import-cardinfo #P"/tmp/cardinfo.json")

|#

(in-package #:cl-user)

(in-package #:cl-deck-builder2.models.ygoprodeck.json)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *json* nil
  "The currently loaded CARDINFO data pulled from YGOProDeck API.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod cardinfo-import ((obj cardinfo) &optional force)
  "Set *JSON* to the decoded JSON data from CARDINFO, by processing it into CARDINFO-JSON using CARDINFO-CONVERT.

Optionally, FORCE the data to be loaded anyway.

If the (CARDINFO-OUTPUT OBJ) does not exist, try to (CARDINFO-INPUT *CARDINFO*)."
  (cardinfo-load obj force)
  (process-all-nodes))

(defmethod cardinfo-load ((obj cardinfo) &optional force)
  (let ((output (cardinfo-output obj)))
    (v:info :ygoprodeck.json "CARDINFO-LOAD ~a (exists:~a) (force:~a)" output (cardinfo-output-exists-p obj) force)
    (if (cardinfo-output-exists-p obj)
        (progn
          (setf *json* (with-open-file (f output)
                         (cl-json:decode-json f)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun json-cardinfo-base-fields (plist)
  "Filter only the base fields for this CARD-INFO PLIST."
  (set-difference plist
                  '((:banlist--info)
                    (:card--images)
                    (:card--prices)
                    (:card--sets)
                    (:linkmarkers)
                    (:misc--info))
                  :key #'car))

;; (defparameter +ygo-card-ids+ (make-hash-table :test #'equal))
;; (defparameter +ygo-card-descs+ (make-hash-table :test #'equal))

;; TODO put all of these hash tables inside another hash table, then
;; make an API around it.  I've seen that done before with CLOS, maybe
;; in cl-opengl defvao stuff. Remember?
(defparameter +ygo-card-names+ (make-hash-table :test #'equal))
(defparameter +ygo-card-types+ (make-hash-table :test #'equal))
(defparameter +ygo-card-races+ (make-hash-table :test #'equal))
(defparameter +ygo-card-frame-types+ (make-hash-table :test #'equal))
(defparameter +ygo-card-archetypes+ (make-hash-table :test #'equal))
(defparameter +ygo-card-attributes+ (make-hash-table :test #'equal))

(defparameter +ygo-set-names+ (make-hash-table :test #'equal))
(defparameter +ygo-set-codes+ (make-hash-table :test #'equal))
(defparameter +ygo-set-rarity+ (make-hash-table :test #'equal))
(defparameter +ygo-set-editions+ (make-hash-table :test #'equal))

;; Here we use the ID/PASSCODE so EQ is Okay
(defparameter +ygo-card-prices+ (make-hash-table)) ;; One to one: setf place
(defparameter +ygo-alternative-artwork+ (make-hash-table)) ;; Many to many: push place

(defparameter +ygo-cards+ (make-hash-table)) ;; One to one: setf place
(defparameter +ygo-sets+ (make-hash-table)) ;; Many to many: push place

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Field Names
(defparameter +ygo-banlist-info+ (make-hash-table))
(defparameter +ygo-format-info+ (make-hash-table))
(defparameter +ygo-linkmarker-info+ (make-hash-table))

(defparameter +ygo-banlist-names+ (make-hash-table :test #'equal))
(defparameter +ygo-format-names+ (make-hash-table :test #'equal))
(defparameter +ygo-linkmarker-names+ (make-hash-table :test #'equal))
(defparameter +ygo-set-rarity-codes+ (make-hash-table :test #'equal))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The bulk of the operation ... FIND-OR-MAKE-INSTANCE + SYNC-HASH-TABLE
(defun sync-hash-table (ht)
  (let ((values (alexandria:hash-table-values ht)))
    (cond ((null values) nil)
          (;; The ht is a bunch of lists (card sets, prices, images)
           (listp (car values))
           (dolist (lst values)
             (unless (mito:dao-synced (car lst))
               (do-grouped-insert lst))))
          (t
           (unless (mito:dao-synced (car values))
             (do-grouped-insert values))))))

;; TODO Where should this go? I'm seeing bits of code like this all over.
(defun %keywordify (s)
  (alexandria:make-keyword
   (string-upcase
    (substitute #\- #\Space s))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Importer v3
(defun extract-json-tag (json tag)
  "Get all the tags from JSON matching TAG."
  (mapcar (lambda (alist) (assoc-utils:aget alist tag)) json))

(defun extract-concat (json tag)
  "Concatenate the results of EXTRACT-JSON-TAG into a single list for MAPCAR'ing."
  (apply #'concatenate 'list (extract-json-tag json tag)))

(defun extract-card-sets (json)
  "Just extract :CARD--SETS. No Processing"
  (extract-concat json :card--sets))

(defun extract-card-set-map (json)
  "Extract PASSCODE => SETS mapping."
  (let ((lst '()))
    (dolist (node json (copy-alist
                        (apply #'concatenate 'list (reverse lst))))
      (let* ((node-id (assoc-utils:aget node :id))
             (maybe-card-sets
               (mapcar (lambda (alist)
                         (acons :passcode-id node-id alist))
                       (assoc-utils:aget node :card--sets))))
        (when maybe-card-sets
          (push maybe-card-sets lst))))))

(defun extract-card-images (json)
  "Just extract :CARD--IMAGES. No Processing"
  (extract-concat json :card--images))

(defun extract-card-alternative-images-map (json)
  "Mapping of ID to alternative art IDs."
  (let ((lst '()))
    (dolist (node json (reverse lst))
      (let* ((alternate-id (assoc-utils:aget node :id))
             (maybe-alternative-images
               (remove alternate-id
                       (mapcar (lambda (alist)
                                 (assoc-utils:aget alist :id))
                               (assoc-utils:aget node :card--images)))))
        (when maybe-alternative-images
          (mapcar (lambda (node-id)
                    (push (list :passcode-id node-id
                                :alternate-id alternate-id)
                          lst))
                  maybe-alternative-images))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Working with the base fields
(defun extract-card-tag (json tag)
  "Extract TAG from JSON using EXTRACT-JSON-TAG. Also, SORT, and SUBSTITUTE NIL for \"\"."
  (sort
   (substitute "" NIL
               (remove-duplicates
                (extract-json-tag json tag)
                :test #'string=))
   #'string<))

(defun extract-card-name (json)
  (extract-card-tag json :name))

(defun extract-card-type (json)
  (extract-card-tag json :type))

(defun extract-card-race (json)
  (extract-card-tag json :race))

(defun extract-card-frame-type (json)
  (extract-card-tag json :frame-type))

(defun extract-card-archetype (json)
  (extract-card-tag json :archetype))

(defun extract-card-attribute (json)
  (extract-card-tag json :attribute))

(defun extract-cards (json)
  "Just extract the base field for every card."
  (mapcar #'json-cardinfo-base-fields json))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun extract-card-banlist-info (json)
  "Lots of cards don't have banlist info records."
  (let ((lst '()))
    (dolist (node json (copy-list lst))
      (let ((node-id (assoc-utils:aget node :id))
            (maybe-banlist-info
              (assoc-utils:alist-plist
               (assoc-utils:aget node :banlist--info))))
        (when maybe-banlist-info
          (push (append (list :passcode-id node-id)
                        maybe-banlist-info)
                lst))))))

(defun extract-card-banlist-names (json)
  "Just extract the names of the ban status. \"Banned\" etc."
  (let ((lst '()))
    (dolist (node json (copy-list lst))
      (let ((maybe-banlist-names
              (assoc-utils:alist-values
               (assoc-utils:aget node :banlist--info))))
        (when maybe-banlist-names
          (loop for name in maybe-banlist-names do
            (pushnew name lst :test #'string=)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun extract-card-prices (json)
  (extract-json-tag json :card--prices))

(defun extract-card-price-map (json)
  "Extract :CARD--PRICE and process into ID => PRICES mapping"
  (let ((lst '()))
    (dolist (node json lst)
      (let ((node-id (assoc-utils:aget node :id))
            (maybe-price-data
              (assoc-utils:alist-plist
               (apply #'concatenate 'list
                      (assoc-utils:aget node :card--prices)))))
        (when maybe-price-data
          (push (append (list :passcode-id node-id)
                        maybe-price-data)
                lst))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun extract-card-misc-info (json)
  (extract-json-tag json :misc--info))

(defun extract-card-misc-info-map (json)
  "Extract :MISC--INFO and process into ID => FORMATS mapping"
  (let ((lst '()))
    (dolist (node json lst)
      (let* ((node-id (assoc-utils:aget node :id))
             (maybe-misc-info
               (assoc-utils:alist-plist
                (remove :formats
                        (apply #'concatenate 'list
                               (assoc-utils:aget node :misc--info))
                        :key #'car))))
        (when maybe-misc-info
          (push (append (list :passcode-id node-id)
                        maybe-misc-info)
                lst))))))

;; TODO
(defun extract-card-format-info (json)
  "Extract :MISC--INFO and process into ID => FORMATS mapping"
  (let ((lst '()))
    (dolist (node json lst)
      (let* ((node-id (assoc-utils:aget node :id))
             (maybe-misc-info
               (assoc-utils:aget 
                (apply #'concatenate 'list
                       (assoc-utils:aget node :misc--info))
                :formats)))
        (when maybe-misc-info
          (push (list node-id maybe-misc-info) lst))))))

;; TODO - The card formats need to be processed like the card-sets and cards
(defun process-card-format-info-map (json)
  (let ((info (extract-card-format-info json)))
    (with-connection (db)
      (with-transaction
        (mapcar (lambda (row)
                  (list :passcode-id (car row)
                        (apply #'concatenate 'list
                               (mapcar (lambda (tag)
                                         (let ((db-tag (or (find-or-create-instance 'ygo-format-name :name tag))))
                                           (list (%keywordify tag) db-tag)))
                                       (cadr row)))))
                info)))))

(defun extract-card-format-names (json)
  (sort
   (remove-duplicates
    (apply #'concatenate 'list
           (mapcar (lambda (alist) (assoc-utils:aget alist :formats))
                   (apply #'concatenate 'list
                          (extract-card-misc-info json))))
    :test #'string=)
   #'string<))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun extract-card-linkmarker-names (json)
  (sort (remove-duplicates
         (extract-concat json :linkmarkers)
         :test #'string=)
        #'string<))

;; TODO
(defun extract-card-linkmarker-info (json)
  "Just extract :CARD--IMAGES. No Processing"
  (let ((lst '()))
    (dolist (node json lst)
      (let ((node-id (assoc-utils:aget node :id))
            (maybe-linkmarkers
              (assoc-utils:aget node :linkmarkers)))
        (when maybe-linkmarkers
          (push (list node-id maybe-linkmarkers) lst))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Working with CARD--SETS

;; Here, JSON shuld be: (extract-card-sets json)
(defun extract-set-tag (json tag)
  (sort (remove-duplicates
         (extract-json-tag json tag)
         :test #'string=)
        #'string<))

(defun extract-set-name (json)
  (extract-set-tag json :set--name))

(defun extract-set-code (json)
  (extract-set-tag json :set--code))

(defun extract-set-rarity (json)
  (extract-set-tag json :set--rarity))

(defun extract-set-rarity-code (json)
  (extract-set-tag json :set--rarity--code))

(defun extract-set-edition (json)
  (extract-set-tag json :set--edition))

(defun extract-set-price (json)
  (extract-set-tag json :set--price))

(defun extract-set-url (json)
  (extract-set-tag json :set--url))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Card Images
(defun extract-card-main-image (json)
  "From :CARD--IMAGES, extract the first IMAGE--URL. The other two are small and cropped images."
  (sort
   (mapcar (lambda (alist) (assoc-utils:aget alist :image--url))
           (extract-concat json :card--images))
   #'string<))

(defun gen-hash-table (ht class tags)
  "Just a list mapping like \"Normal\" => 1, \"Tested\" => 2, and so on. Could be used for anything that has a NAME column."
  (v:info :ygoprodeck.json "GEN-HASH-TABLE: ~a" class)
  (with-connection (db)
    (with-transaction
      (dolist (tag tags ht)
        (unless (gethash tag ht)
          (setf (gethash tag ht)
                (or (mito:find-dao class :name tag)
                    (mito:create-dao class :name tag))))))))

(defun gen-hash-mapping-table (class tags &key (test 'equal))
  "A more complex mapping of PASSCODE -> DATA"
  (let ((ht (make-hash-table :test test)))
    (with-connection (db)
      (with-transaction
        (dolist (node tags ht)
          (let ((passcode-id (getf node :passcode-id)))
            (setf (gethash passcode-id ht)
                  (or (mito:find-dao class :passcode-id passcode-id)
                      (apply #'mito:create-dao class node)))))))))

(defun gen-hash-map-list-table (class tags &key (test 'equal))
  "A more complex mapping of PASSCODE -> (DATA, DATA, DATA)"
  (let ((ht (make-hash-table :test test)))
    (with-connection (db)
      (with-transaction
        (dolist (node tags ht)
          (let ((passcode-id (getf node :passcode-id)))
            (push (or (apply #'mito:find-dao class node)
                      (apply #'mito:create-dao class node))
                  (gethash passcode-id ht))))))))

(defun process-card-nodes (json)
  "Mostly preserved from V2."
  (let* ((base-fields (json-cardinfo-base-fields json))
         (id (assoc-utils:aget base-fields :id))
         (args (list
                :name (assoc-utils:aget base-fields :name)
                :desc (assoc-utils:aget base-fields :desc)
                :archetype (gethash (assoc-utils:aget base-fields :archetype) +ygo-card-archetypes+)
                :attribute (gethash (assoc-utils:aget base-fields :attribute) +ygo-card-attributes+)
                :frame-type (gethash (assoc-utils:aget base-fields :frame-type) +ygo-card-frame-types+)
                :race (gethash (assoc-utils:aget base-fields :race) +ygo-card-races+)
                :card-type (gethash (assoc-utils:aget base-fields :type) +ygo-card-types+)
                :atk (assoc-utils:aget base-fields :atk)
                :def (assoc-utils:aget base-fields :def)
                :scale (assoc-utils:aget base-fields :scale)
                :level (assoc-utils:aget base-fields :level)))
         (found (or (mito:find-dao 'ygo-card :id id)
                    (apply #'create-dao 'ygo-card :id id args))))
    (unless (gethash id +ygo-cards+)
      (setf (gethash id +ygo-cards+) found))))

(defun process-card-sets (&rest sets)
  "Mostly preserved from V2."
  (dolist (node sets +ygo-sets+)
    (let* ((args
             (list :passcode-id (assoc-utils:aget node :passcode-id)
                   :code (gethash (assoc-utils:aget node :set--code) +ygo-set-codes+)
                   :name (gethash (assoc-utils:aget node :set--name) +ygo-set-names+)
                   :edition (gethash (assoc-utils:aget node :set--edition) +ygo-set-editions+)
                   :rarity (gethash (assoc-utils:aget node :set--rarity) +ygo-set-rarity+)
                   :rarity-code (gethash (assoc-utils:aget node :set--rarity--code) +ygo-set-rarity-codes+)))
           (rest-args
             (list :price (assoc-utils:aget node :set--price)
                   :url (assoc-utils:aget node :set--url)))
           (found (or (apply #'mito:find-dao 'ygo-set args)
                      (apply #'mito:create-dao 'ygo-set (append args rest-args)))))
      (pushnew found
               (gethash (assoc-utils:aget node :passcode-id) +ygo-sets+)
               :test #'mito:object=))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TODO for Import-v4 - It might be useful to have PASSCODE as the ID,
;; that way, there is a uniform interface for querying card info...
;;
;; TODO Split this up?
(defun pre-process-nodes (json)
  (let ((card-names (extract-card-name json))
        (card-types (extract-card-type json))
        (card-races (extract-card-race json))
        (card-frame-types (extract-card-frame-type json))
        (card-archetypes (extract-card-archetype json))
        (card-attributes (extract-card-attribute json))
        (card-sets (extract-card-sets json)))

    (gen-hash-table +ygo-card-names+ 'ygo-card-name card-names)
    (gen-hash-table +ygo-card-archetypes+ 'ygo-card-archetype card-archetypes)
    (gen-hash-table +ygo-card-attributes+ 'ygo-card-attribute card-attributes)
    (gen-hash-table +ygo-card-frame-types+ 'ygo-card-frame-type card-frame-types)
    (gen-hash-table +ygo-card-races+ 'ygo-card-race card-races)
    (gen-hash-table +ygo-card-types+ 'ygo-card-type card-types)

    (gen-hash-table +ygo-set-names+ 'ygo-set-name (extract-set-name card-sets))
    (gen-hash-table +ygo-set-codes+ 'ygo-set-code (extract-set-code card-sets))
    (gen-hash-table +ygo-set-rarity+ 'ygo-set-rarity (extract-set-rarity card-sets))
    (gen-hash-table +ygo-set-editions+ 'ygo-set-edition (extract-set-edition card-sets))
    (gen-hash-table +ygo-set-rarity-codes+ 'ygo-set-rarity-code (extract-set-rarity-code card-sets))

    (gen-hash-table +ygo-banlist-names+ 'ygo-banlist-name (extract-card-banlist-info card-sets))
    (gen-hash-table +ygo-linkmarker-names+ 'ygo-linkmarker-name (extract-card-linkmarker-names card-sets))
    (gen-hash-table +ygo-format-names+ 'ygo-format-name (extract-card-format-names json))))

(defun pre-process-card-prices (json)
  (setf +ygo-card-prices+ (gen-hash-mapping-table 'ygo-price (extract-card-price-map json) :test 'eq)))

(defun pre-process-card-alternative-artwork (json)
  (setf +ygo-alternative-artwork+ (gen-hash-map-list-table 'ygo-alternative-artwork (extract-card-alternative-images-map json) :test 'eq)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun process-all-nodes (&optional (json *json*))
  "Process all nodes from JSON."
  (v:info :ygoprodeck.json "PROCESS-ALL-NODES: PRE-PROCESS-NODES")
  (pre-process-nodes json)
  (pre-process-card-prices json)
  (pre-process-card-alternative-artwork json)

  ;; +ygo-cards+
  (v:info :ygoprodeck.json "PROCESS-ALL-NODES: PROCESS-CARD-NODES")
  (with-connection (db)
    (with-transaction
      (mapcan #'process-card-nodes json)))

  ;; +ygo-sets+
  (v:info :ygoprodeck.json "PROCESS-ALL-NODES: PROCESS-CARD-SETS")
  (with-connection (db)
    (with-transaction
      (apply #'process-card-sets (extract-card-set-map json)))))