130 lines
5.7 KiB
Plaintext
130 lines
5.7 KiB
Plaintext
// Lib is its own class because, while it would make sense to group its functions and macros in Archive.kiss,
|
|
// other files would not be able to (load "Archive.kiss") for the macro definitions without taking on Archive's constructor.
|
|
|
|
// External programs can load Lib.kiss with (loadFrom "nat-archive-tool" "src/nat/Lib.kiss")
|
|
|
|
(function _log [msg]
|
|
(#when (or test debug) (print msg)))
|
|
|
|
(defMacro log [ui msg]
|
|
(withEvalOnce [ui msg]
|
|
(when ui
|
|
(ui.displayMessage msg))
|
|
(_log msg)))
|
|
|
|
(defMacro hasComponent [e componentType]
|
|
`(.exists .components ,e ,(symbolName componentType)))
|
|
|
|
// Changes to the object returned by (readComponent) will not be saved! Use (withWritableComponents) for making changes
|
|
(defMacro readComponent [e componentType]
|
|
`(let [componentData (dictGet (the Map<String,String> .components ,e) ,(symbolName componentType))]
|
|
// (log null (+ "reading " componentData " as " ,(symbolName componentType) " for " .id ,e))
|
|
(the nat.components ,componentType
|
|
// TODO add to the documentation a hint that macros should use fully qualified type paths so macro caller classes don't need to import everything
|
|
(tink.Json.parse componentData))))
|
|
|
|
// Return either the desired component, or def if no such component exists
|
|
(defMacro readComponentOr [e componentType def]
|
|
(withEvalOnce [e]
|
|
(if (hasComponent e ,componentType)
|
|
(readComponent e ,componentType)
|
|
,def)))
|
|
|
|
// TODO check not overwriting a component
|
|
(defMacro addComponent [archive e componentType c]
|
|
`(withWritableEntry ,archive ,e
|
|
(log null (+ "adding " (the nat.components ,componentType ,c) " as " ,(symbolName componentType) " for " .id ,e))
|
|
(dictSet .components ,e ,(symbolName componentType) (tink.Json.stringify (the nat.components ,componentType ,c)))))
|
|
|
|
(defMacro removeComponent [archive e componentType]
|
|
`(withWritableEntry ,archive ,e
|
|
(log null (+ "removing " ,(symbolName componentType) " component from " .id ,e))
|
|
(.remove .components ,e ,(symbolName componentType))))
|
|
|
|
// Retrieve multiple components from an Entity with mutable access.
|
|
// All components will be serialized after the block is done.
|
|
(defMacro withWritableComponents [archive e bindings &body body]
|
|
(let [bindingPairs
|
|
(groups (expList bindings) 2 Throw)
|
|
bindingList
|
|
[]
|
|
saveList
|
|
[]
|
|
retValSymbol
|
|
(symbol)]
|
|
(doFor [name type] bindingPairs
|
|
(bindingList.push `&mut ,name)
|
|
(bindingList.push `(readComponent ,e ,type))
|
|
(saveList.push `(dictSet .components ,e ,(symbolName type) (tink.Json.stringify (the nat.components ,type ,name)))))
|
|
`(let [,@bindingList
|
|
,retValSymbol {,@body}]
|
|
,@saveList
|
|
(.refreshEntry ,archive ,e) // Check the entry in and out of systems when its components change
|
|
,retValSymbol)))
|
|
|
|
(defMacro withWritableEntry [archive e &body body]
|
|
(let [retValSymbol
|
|
(symbol)]
|
|
`(let [,retValSymbol {,@body}]
|
|
(.refreshEntry ,archive ,e)
|
|
,retValSymbol)))
|
|
|
|
// Create a system that selects Entries according to a single string component (i.e. Name or Author) matching the given value
|
|
(defMacro stringComponentSystem [componentType value process]
|
|
`(new System
|
|
(lambda [archive :nat.Entry e]
|
|
?(and (hasComponent e ,componentType)
|
|
(= ,value (readComponent e ,componentType))))
|
|
,process))
|
|
|
|
(function :Array<String> tagList [:nat.Entry e]
|
|
(if (hasComponent e Tags)
|
|
(let [t (readComponent e Tags)]
|
|
(collect (t.keys)))
|
|
[]))
|
|
|
|
(function tagsMatch [e tagsBoolExp]
|
|
(BoolExpInterp.eval tagsBoolExp (tagList e)))
|
|
|
|
(function componentsMatch [:nat.Entry e componentsBoolExp]
|
|
(BoolExpInterp.eval componentsBoolExp (for =>cType cId e.components cType)))
|
|
|
|
(function componentsAndTagsMatch [:nat.Entry e componentsAndTagsBoolExp]
|
|
(BoolExpInterp.eval componentsAndTagsBoolExp (cast (concat (tagList e) (for =>cType cId e.components cType)))))
|
|
|
|
(defAlias &call catsMatch componentsAndTagsMatch)
|
|
|
|
(function addFiles [:nat.Archive archive :nat.Entry e :Array<String> files &opt leaveOriginalCopy]
|
|
(withWritableEntry archive e
|
|
(doFor file files
|
|
(let [pathWithoutDir (haxe.io.Path.withoutDirectory file)]
|
|
(unless (contains e.files pathWithoutDir)
|
|
(let [pathInArchive (joinPath archive.archiveDir "files" pathWithoutDir)]
|
|
(unless (sys.FileSystem.exists pathInArchive)
|
|
((if leaveOriginalCopy sys.io.File.copy sys.FileSystem.rename)
|
|
file pathInArchive)))
|
|
(e.files.push pathWithoutDir))))))
|
|
|
|
(function removeFiles [:nat.Archive archive :nat.Entry e :Array<String> files]
|
|
(withWritableEntry archive e
|
|
(doFor file files
|
|
(e.files.remove file))))
|
|
|
|
(function addTags [:nat.Archive archive :nat.Entry e :Array<String> tagsToAdd]
|
|
(if (hasComponent e Tags)
|
|
(withWritableComponents archive e [tags Tags]
|
|
(doFor tag tagsToAdd (dictSet tags tag 1)))
|
|
(addComponent archive e Tags (for tag tagsToAdd =>tag 1))))
|
|
|
|
(function removeTags [:nat.Archive archive :nat.Entry e :Array<String> tagsToRemove]
|
|
(when (hasComponent e Tags)
|
|
(withWritableComponents archive e [tags Tags]
|
|
(doFor tag tagsToRemove (tags.remove tag)))))
|
|
|
|
(function :Float getScale [:nat.Entry e]
|
|
(if (hasComponent e Images2)
|
|
(let [i2 (readComponent e Images2)]
|
|
(nth i2.imageScales i2.pinnedImageIndex))
|
|
(if (hasComponent e Scale)
|
|
(readComponent e Scale)
|
|
1.0))) |