Use int-based colors for tag-color systems in NAT. Close #167

projects/nat-archive-tool/src/nat/ArchiveController.kiss

@@ -182,7 +182,8 @@
             // Preserve the capitalization of the command name for pretty help message
             (commandNames.push ,(symbolName name))
             // Store the command name without capitalization for forgiving call conventions
-            (dictSet commands ,(ReaderExp.StrExp (.toLowerCase (symbolNameValue name))) (object args [,@commandArgs] handler (the Function ,name)))}))
+            (dictSet commands ,(ReaderExp.StrExp (.toLowerCase (symbolNameValue name))) (object args [,@commandArgs] handler (the Function ,name)))
+        }))
 
 (var :Array<String> commandNames [])
 
@@ -211,25 +212,25 @@
     (archive.addSystem (new KeyShortcutSystem this))
     (archive.addSystem (new DLSystem))
     (archive.addSystem (new AutoStepperSystem))
+    (archive.addSystem (new ColorSystem))
     
-    // TODO this needs to use epsilon!
-    (localFunction colorEqual [:nat.components.Color c1 :nat.components.Color c2]
+    (localFunction colorEqual [:nat.components.ColorI c1 :nat.components.ColorI c2]
         (and (= c1.r c2.r) (= c1.g c2.g) (= c1.b c2.b) (= c1.a c2.a)))
-    (localFunction colorsContain [:Array<nat.components.Color> cs :nat.components.Color c1]
+    (localFunction colorsContain [:Array<nat.components.ColorI> cs :nat.components.ColorI c1]
         (doFor c2 cs
             (when (colorEqual c2 c1)
                 (return true)))
         (return false))
-    (localFunction addColorTagSystems [:Map<String,nat.components.Color> info]
+    (localFunction addColorTagSystems [:Map<String,nat.components.ColorI> info]
         (let [colors (collect (info.iterator))]
             (doFor =>tagExp color info
                 (archive.addSystem (new TagSystem tagExp ->[archive e &opt ui]
-                    (when (or !(hasComponent e Color) (colorsContain colors (readComponent e Color)))
-                        (addComponent archive e Color color)))))))
+                    (when (or !(hasComponent e ColorI) (colorsContain colors (readComponent e ColorI)))
+                        (AddColorIRGBA [e] color.r color.g color.b color.a)))))))
     (addColorTagSystems [
-        =>"(or active enabled)" (object r 0 g 1 b 0 a 1)
-        =>"(or inactive disabled)" (object r 0.5 g 0.5 b 0.5 a 1)
-        =>"todo" (object r 1 g 0.5 b 0 a 1)])
+        =>"(or active enabled)" (object r 0 g 255 b 0 a 255)
+        =>"(or inactive disabled)" (object r 128 g 128 b 128 a 255)
+        =>"todo" (object r 255 g 128 b 0 a 255)])
 
     (whenLet [ps (ui.playgroundSystem)]
         (set playgroundSystem ps)
@@ -397,7 +398,11 @@
         (for e entries
             (addConnections archive e entriesToRemove)))
     
-    (defCommand AddColorRGBA [entries (SelectedEntries 1 null) r (Number 0 1 null) g (Number 0 1 null) b (Number 0 1 null) a (Number 0 1 null)]
+    (defCommand AddColorFRGBA [entries (SelectedEntries 1 null) r (Number 0 1 null) g (Number 0 1 null) b (Number 0 1 null) a (Number 0 1 null)]
         (for e entries
-            (addColorRGBA archive e r g b a)))
+            (addColorFRGBA archive e r g b a)))
+
+    (defCommand AddColorIRGBA [entries (SelectedEntries 1 null) r (Number 0 255 1) g (Number 0 255 1) b (Number 0 255 1) a (Number 0 255 1)]
+        (for e entries
+            (addColorIRGBA archive e (Std.int r) (Std.int g) (Std.int b) (Std.int a))))
     )

projects/nat-archive-tool/src/nat/Lib.kiss

@@ -149,8 +149,21 @@
             (doFor e2 entriesToRemove (conn.remove e2.id))))
     e)
 
-(function addColorRGBA [:nat.Archive archive :nat.Entry e :Float r :Float g :Float b :Float a]
-    (addComponent archive e Color (objectWith r g b a)))
+(function colorIFromF [:nat.components.ColorF cf]
+    (object r (Std.int (* 255 cf.r)) g (Std.int (* 255 cf.g)) b (Std.int (* 255 cf.b)) a (Std.int (* 255 cf.a))))
+
+(function colorFFromI [:nat.components.ColorI ci]
+    (object r (/ ci.r 255.0) g (/ ci.g 255.0) b (/ ci.b 255.0) a (/ ci.a 255)))
+
+(function addColorFRGBA [:nat.Archive archive :nat.Entry e :Float r :Float g :Float b :Float a]
+    (let [cf (objectWith r g b a)]
+        (addComponent archive e ColorF cf)
+        (addComponent archive e ColorI (colorIFromF cf))))
+
+(function addColorIRGBA [:nat.Archive archive :nat.Entry e :Int r :Int g :Int b :Int a]
+    (let [ci (objectWith r g b a)]
+        (addComponent archive e ColorI ci)
+        (addComponent archive e ColorF (colorFFromI ci))))
 
 (function isEntry [o]
     (let [fields (Reflect.fields o)]

projects/nat-archive-tool/src/nat/components/ColorF.hx

@@ -0,0 +1,8 @@
+package nat.components;
+
+typedef ColorF = {
+    r:Float,
+    g:Float,
+    b:Float,
+    a:Float
+};

projects/nat-archive-tool/src/nat/components/ColorI.hx

@@ -0,0 +1,8 @@
+package nat.components;
+
+typedef ColorI = {
+    r:Int,
+    g:Int,
+    b:Int,
+    a:Int
+};

projects/nat-archive-tool/src/nat/systems/ColorSystem.hx

@@ -0,0 +1,8 @@
+package nat.systems;
+
+import kiss.Prelude;
+import kiss.List;
+import nat.System;
+
+@:build(kiss.Kiss.build())
+class ColorSystem extends System {}

projects/nat-archive-tool/src/nat/systems/ColorSystem.kiss

@@ -0,0 +1,14 @@
+(load "../Lib.kiss")
+
+// Converts outdated Color component into a ColorF component and a ColorI component
+
+(defNew []
+    (super
+        ->[archive e]
+            (hasComponent e Color)
+        ->[archive e &opt ui]
+            (let [c (readComponent e Color)]
+                (addComponent archive e ColorF c)
+                (addComponent archive e ColorI (colorIFromF c))
+                (removeComponent archive e Color))))
+

projects/nat-archive-tool/src/nat/systems/PlaygroundSystem.kiss

@@ -5,7 +5,7 @@
 (method :String getPlaygroundKey [] _playgroundKey)
 
 (prop :Map<String,TagList> playgroundDefaultTags (new Map))
-(prop :Map<String,Color> playgroundBGColors (new Map))
+(prop :Map<String,ColorF> playgroundBGColors (new Map))
 
 (defNew [&prop :ArchiveUI ui
             :EntryChecker canProcess
@@ -25,7 +25,7 @@
                             (if (hasComponent e CatsMatchExp)
                                     (archive.changePlaygrounds ->:Void [:DynamicAccess<Dynamic> p] (set .catsMatch (dictGet p name) (readComponent e CatsMatchExp)))
                                 (addComponent archive e CatsMatchExp .catsMatch (dictGet archive.playgrounds name)))
-                            (dictSet playgroundBGColors name (readComponentOr e Color (object r 0.0 g 0.0 b 0.0 a 1.0)))
+                            (dictSet playgroundBGColors name (readComponentOr e ColorF (object r 0.0 g 0.0 b 0.0 a 1.0)))
                             (dictSet playgroundDefaultTags name (readComponentOr e TagList []))))
 
                 // Process Entries belonging to the current playground
@@ -52,7 +52,7 @@
         })
     (process ui.controller.archive ui))
 
-(method :Void clear [:Color color]
+(method :Void clear [:ColorF color]
     (throw "(PlaygroundSystem.clear <color>) not implemented"))
 
 (prop &mut :Bool setupProcess false)