|
- #|
-
- 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)))))
|