add play-tags

4 files changed, 235 insertions, 0 deletions

diff --git a/app/index.moon b/app/index.moon
index 9b94436..daec767 100644
--- a/app/index.moon
+++ b/app/index.moon
@@ -10,6 +10,7 @@ demos =
   'realities': 'draft of a paper on virtual and other realities',
   'center-of-mass': 'aligning characters by their centers of mass',
   'test-component': 'Test suite for the UI framework',
+  'play-tags': 'Playground for Functional Tags',
 
 back_button = ->
   document.body\appendChild p a { '< back', href: '/' }
@@ -30,6 +31,9 @@ switch window.location.search
   when '?realities' then
     back_button!
     require './realities.moon'
+  when '?play-tags' then
+    back_button!
+    require './play_tags.moon'
   else
     document.body\appendChild h1 'mmm'
     document.body\appendChild p {
diff --git a/app/play_tags.moon b/app/play_tags.moon
new file mode 100644
index 0000000..68d6710
--- /dev/null
+++ b/app/play_tags.moon
@@ -0,0 +1,85 @@
+import add_tag, rmv_tag, Node, Hierarchy, Toggle, NamespacedToggle from require './tags.moon'
+import ReactiveVar, append, asnode, text, div, form, span, h3, a, input, textarea, button from require './component.moon'
+
+clone = (set) ->
+  assert set and 'table' == (type set), 'not a set'
+  { k,v for k,v in pairs set }
+set_append = (val) -> (set) ->
+  with copy = clone set
+    copy[val] = val
+set_remove = (val) -> (set) ->
+  with copy = clone set
+    copy[val] = nil
+set_join = (tbl, sep=' ') ->
+  ret = ''
+  for tag in pairs tbl
+    ret ..= (tostring tag) .. sep
+  ret
+
+entries = div!
+append entries
+
+class ReactiveNode extends Node
+  new: (...) =>
+    super ...
+    @tags = ReactiveVar @tags
+    @_node = div {
+        span @name, style: { 'font-weight': 'bold' },
+        @tags\map (tags) -> with div!
+            for tag,_ in pairs tags
+              \append a (text tag), href: '#', style: {
+                display: 'inline-block',
+                margin: '0 5px',
+              }
+      }
+    @node = asnode @_node
+
+  has: (tag) => @tags\get![tag]
+  add: (tag) => @tags\transform set_append tag
+  rmv: (tag) => @tags\transform set_remove tag
+
+rules = {
+  Hierarchy 'home', 'sol'
+  Hierarchy 'sol', 'desktop'
+  Hierarchy 'desktop', 'vacation'
+  Hierarchy 'desktop', 'documents'
+  NamespacedToggle 'documents', 'work', 'personal'
+  -- Toggle 'work', 'personal'
+  -- Hierarchy 'documents', 'work'
+  -- Hierarchy 'documents', 'personal'
+}
+
+pictures = for i=1,10
+  with node = ReactiveNode "picture#{i}.jpg"
+    entries\append node
+    add_tag node, 'vacation'
+
+pers = ReactiveNode 'mypersonalfile.doc'
+entries\append pers
+
+append div do
+  yield = coroutine.yield
+  step = coroutine.wrap ->
+    yield "mark document"
+    add_tag pers, 'documents'
+
+    yield "mark personal"
+    add_tag pers, 'personal'
+
+    yield "mark work"
+    add_tag pers, 'work'
+
+    yield "unmark work"
+    rmv_tag pers, 'work'
+
+    yield "remove from documents"
+    rmv_tag pers, 'documents'
+
+    yield false
+
+  next_step = ReactiveVar step!
+  next_step\map (desc) ->
+    if desc
+      button (text desc), onclick: (e) => next_step\set step!
+    else
+      text ''
diff --git a/app/tags.moon b/app/tags.moon
new file mode 100644
index 0000000..198392e
--- /dev/null
+++ b/app/tags.moon
@@ -0,0 +1,146 @@
+join = (tbl, sep) ->
+  ret = ''
+  for tag in pairs tbl
+    ret ..= (tostring tag) .. sep
+  ret
+
+handlers = {
+  add: {}
+  rmv: {}
+}
+
+class Node
+  new: (@name) =>
+    @tags = {}
+
+  inspect: =>
+    "#{@name}: [#{join @tags, ' '}]"
+
+  has: (tag) => @tags[tag]
+  add: (tag) => @tags[tag] = tag
+  rmv: (tag) => @tags[tag] = nil
+
+any = -> true
+literal = (def) -> (val) -> def == val
+oneof   = (defs) -> (val) ->
+  for def in *defs
+    return true if def == val
+  false
+has = (tag) -> (node) -> node\has tag
+
+add_tag = (node, tag) ->
+  return if node\has tag
+  node\add tag
+  for hand, _ in pairs handlers.add
+    hand\match node, tag
+
+rmv_tag = (node, tag) ->
+  return if not node\has tag
+  node\rmv tag
+  for hand, _ in pairs handlers.rmv
+    hand\match node, tag
+
+class Handler
+  new: (@rule, @action, match, @func) =>
+    @args = for arg in *match
+      if 'string' == type arg
+        literal arg
+      elseif 'table' == type arg
+        oneof arg
+      else
+        arg
+
+  match: (...) =>
+    supplied = { ... }
+    assert #supplied == #@args, 'length of arguments doesnt match'
+    for i = 1, #supplied
+      return false if not @args[i] supplied[i]
+
+    @.func @rule, ...
+
+  name: => "#{@rule.name}:#{@action}"
+
+class Rule
+  new: (@name="#{@@__name}") =>
+    @owned_handlers = {}
+
+  hook: (action, ...) =>
+    handler = Handler @, action, ...
+    table.insert @owned_handlers, handler
+    handlers[action][handler] = handler
+
+  destroy: =>
+    for hand in *@owned_handlers
+      handlers[hand.action][hand] = nil
+
+class Hierarchy extends Rule
+  new: (@parent, @child) =>
+    super!
+
+    -- when something is tagged with the child-tag, apply the parent tag
+    @hook 'add', { any, @child }, (node) =>
+      add_tag node, @parent
+
+    -- when child tag is removed, remove parent tag
+    @hook 'rmv', { any, @child }, (node) =>
+      rmv_tag node, @parent
+
+    -- when parent tag is removed, remove child tag
+    @hook 'rmv', { any, @parent }, (node) =>
+      rmv_tag node, @child
+
+class Toggle extends Rule
+  new: (@a, @b) =>
+    super!
+
+    either = { @a, @b }
+    opposite = (tag) -> if tag == @a then @b else @a
+
+    -- when a is added, remove b and vice-versa
+    @hook 'add', { any, either }, (node, tag) =>
+      rmv_tag node, opposite tag
+
+    -- when a is removed, add b and vice-versa
+    @hook 'rmv', { any, either }, (node, tag) =>
+      add_tag node, opposite tag
+
+class NamespacedToggle extends Rule
+  new: (@ns, @a, @b) =>
+    super!
+
+    namespaced = has @ns
+    either = { @a, @b }
+    opposite = (tag) -> if tag == @a then @b else @a
+
+    -- when node enters namespace, add default tag
+    @hook 'add', { any, @ns }, (node) =>
+      add_tag node, @a
+
+    -- when node leaves namespace, remove tags
+    @hook 'rmv', { any, @ns }, (node) =>
+      rmv_tag node, @a
+      rmv_tag node, @b
+
+    -- when a is added, remove b and vice-versa
+    @hook 'add', { namespaced, either }, (node, tag) =>
+      rmv_tag node, opposite tag
+
+    -- when a is removed, add b and vice-versa
+    @hook 'rmv', { namespaced, either }, (node, tag) =>
+      add_tag node, opposite tag
+
+{
+  :Node,
+  :Rule,
+
+  :any,
+  :literal,
+  :oneof,
+  :has,
+  :add_tag,
+  :rmv_tag,
+
+  :Hierarchy,
+  :Toggle,
+  :NamespacedToggle,
+}
diff --git a/dist b/dist
-Subproject f0700a9c142f4bd1f8404e6977e01c82e0ded24
+Subproject 7244d9a6fc301962748cb69a2ffd8cb277a99d9