Protoconcepts (tomhanika#99)

* add Protoconcept data type

* add preconcepts? and protoconcepts? function

* add protoconcept functions and tests

* fix preconcepts? tests

* add semiconcept? function

* add protoconcepts order and visualization

* add tests for protoconcept-layout

* use preconcepts? as defined by R. Wille

* add draw-protoconcepts function

* add print method for protoconcepts

* fix errors

* enable draw for protoconcepts

* add more protoconcepts functions and tests

* remove functions that are not needed any more fore protoconcepts

* add draw functions for posets and protoconcepts

* improve documentation

* add documentation for protoconcepts

* minor changes in documentation

* minor changes in documentation

* minor changes in documentation

README.md

@@ -36,6 +36,7 @@ much more.
    1. [pq-cores](doc/pq-cores-in-Formal-Contexts.md)
    2. [REST-API Usage](doc/REST-API-usage.md)
    3. [triadic-exploration](doc/Triadic-Exploration.org)
+   4. [protoconcepts](doc/Protoconcepts.org)
 6. [API documentation](doc/API.md)
 7. [Development](doc/Development.org)
 

doc/Concept-Lattices.org

@@ -173,4 +173,5 @@ switched on.
 
 Other interesting functions are ~draw-layout~, which implements the drawing of
 layouts, and ~draw-concept-lattice~, which draws the concept-lattice of a given
-formal context.
+formal context. With ~draw-poset~ and ~draw-protoconcepts~, Ordered Sets and 
+Protoconcepts can be drawn as well.

doc/Protoconcepts.org

@@ -0,0 +1,91 @@
+#+property: header-args :wrap src text
+#+property: header-args:text :eval never
+
+* Protoconcepts in ~conexp-clj~
+
+Protoconcepts are defined as $(A, B)$, $A \subseteq G$ and $B \subseteq M$ with 
+$A' = B''$ or $B' = A''$.
+
+** Computing Protoconcepts
+
+The protoconcepts of a given context can be computed. First, the respective 
+namespace needs to be loaded.
+#+begin_src clojure :results silent
+(use 'conexp.fca.protoconcepts)
+#+end_src
+
+Let the context be
+#+begin_src clojure :exports both
+(def ctx 
+  (make-context-from-matrix [1 2 3 4]
+                            ['A 'B 'C]
+                            [1 1 0
+                             1 0 0
+                             0 1 0
+                             0 1 0]))
+#+end_src
+
+#+RESULTS:
+#+begin_src text
+  |A B C 
+--+------
+1 |x x . 
+2 |x . . 
+3 |. x .
+4 |. x .
+#+end_src
+
+The protoconcepts can be computed with the ~protoconcepts~ function.
+#+begin_src clojure :exports both
+(protoconcepts ctx)
+#+end_src
+
+#+RESULTS:
+#+begin_src clojure
+#{[#{4 2} #{}] [#{1 3 2} #{}] [#{1 2} #{A}] [#{1} #{A B}]
+  [#{} #{B C}] [#{} #{C}] [#{1 4 2} #{}] [#{4} #{B}] [#{1 4 3 2} #{}]
+  [#{4 3 2} #{}] [#{1 3} #{B}] [#{3 2} #{}] [#{1 4 3} #{B}]
+  [#{3} #{B}] [#{4 3} #{B}] [#{2} #{A}] [#{1 4} #{B}] [#{} #{A C}]
+  [#{} #{A B C}]}
+#+end_src
+
+To compute the protoconcepts as an ordered set, the ~protoconcepts-order~ function can be used.
+#+begin_src clojure :exports both
+(protoconcepts-order ctx)
+#+end_src
+
+#+RESULTS:
+#+begin_src clojure
+Protoconcepts on 19 elements.
+#+end_src
+
+** Draw Protoconcepts
+
+Drawing must be enabled via
+#+begin_src clojure :results silent
+(use 'conexp.gui.draw)
+#+end_src
+
+To draw the ordered protoconcepts of a context, the ~draw-protoconcepts~ function can be used.
+#+begin_src clojure :results silent
+(draw-protoconcepts (protoconcepts-order ctx))
+#+end_src
+
+The protoconcepts graph is shown in an additional window.
+
+#+caption: Protoconcept example
+[[./images/protoconcept-lattice.png]]
+
+Like for [lattices](./Concept-Lattices.org), the layout function can be specified for 
+protoconcepts.
+
+#+begin_src clojure :results silent
+(draw-protoconcepts (protoconcepts-order ctx) 
+                    :layout-fn conexp.layouts.dim-draw/dim-draw-layout)
+#+end_src
+
+#+caption: Protoconcept example with DimDraw layout
+[[./images/protoconcept-lattice-dimdraw.png]]
+
+Notice that the protoconcept orders do not necessarily are a lattice. As many 
+of the value functions only work on lattices, they cannot be applied to protoconcepts.

src/main/clojure/conexp/fca/cover.clj

@@ -373,3 +373,5 @@
                   (do (await cur-lattice) @cur-lattice)
                   (let [bin-closure (next-closed-set-iterator bin-ctx bin-next)]
                     (recur (to-hashset attr-order bin-closure) bin-closure)))))))))
+
+

src/main/clojure/conexp/fca/protoconcepts.clj

@@ -0,0 +1,93 @@
+;; Copyright ⓒ the conexp-clj developers; all rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file LICENSE at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns conexp.fca.protoconcepts
+  "Basis datastructure and definitions for protoconcepts.
+  DOI:https://doi.org/10.1007/11528784_2"
+  (:require [conexp.base :refer :all]
+            [conexp.math.algebra :refer :all]
+            [conexp.fca.contexts :refer :all]
+            [conexp.fca.lattices :refer :all]
+            [conexp.fca.posets :refer :all]))
+
+(deftype Protoconcepts [base-set order-function]
+  Object
+  (equals [this other]
+    (and (= (class this) (class other))
+         (= (.base-set this) (.base-set ^Protoconcepts other))
+         (let [order-this (.order this),
+               order-other (.order other)]
+           (or (= order-this order-other)
+               (forall [x (.base-set this)
+                        y (.base-set this)]
+                       (<=> (order-this x y)
+                            (order-other x y)))))))
+  (hashCode [this]
+    (hash-combine-hash Protoconcepts base-set))
+  ;;
+  Order
+  (base-set [this] base-set)
+  (order [this]
+    (fn order-fn
+      ([pair] (order-function (first pair) (second pair)))
+      ([x y] (order-function x y)))))
+
+(defmethod print-method Protoconcepts [^Protoconcepts protoconcepts, ^java.io.Writer out]
+  (.write out
+          ^String (str "Protoconcepts on " (count (base-set protoconcepts)) " elements.")))
+
+(defn protoconcept?
+  "Tests whether given pair is protoconcept in given context ctx."
+  [ctx [set-of-obj set-of-att]]
+  (or (= (object-derivation ctx set-of-obj)
+         (context-attribute-closure ctx set-of-att))
+      (= (context-object-closure ctx set-of-obj)
+         (attribute-derivation ctx set-of-att))))
+
+(defn protoconcepts?
+  "Tests whether given tuples all are protoconcepts in given context ctx."
+  [ctx protoconcepts]
+  (every? (partial protoconcept? ctx) protoconcepts))
+
+(defn protoconcepts
+  "Computes all protoconcepts of a context."
+  [ctx]
+  (let [object-equivalence-classes (group-by #(object-derivation ctx %) (subsets (objects ctx)))
+        attribute-equivalence-classes (group-by #(context-attribute-closure ctx %) (subsets (attributes ctx)))]
+    (into #{} (apply concat (map (fn [key] 
+                                   (for [obj (get object-equivalence-classes key) 
+                                         attr (get attribute-equivalence-classes key)] 
+                                     [obj attr])) (keys object-equivalence-classes))))))
+
+(defn make-protoconcepts-nc
+  "Creates a new protoconcept order from the given base-set and order-function, without any checks."
+  [base-set order-function]
+  (Protoconcepts. base-set order-function))
+
+(defn make-protoconcepts
+  "Creates a new protoconcepts order from the given base-set and order-function.
+  Checks if the result has partial order, which may take some time. If you don't want this, use make-protoconcepts-nc."
+  ([base-set order-function]
+   (let [protoconcepts (make-protoconcepts-nc base-set order-function)]
+     (when-not (has-partial-order? protoconcepts)
+       (illegal-argument "Given arguments do not describe a partial order."))
+     protoconcepts))
+  ;; checks if result only contains protoconcepts of context ctx
+  ([base-set order-function ctx]
+   (let [protoconcepts (make-protoconcepts base-set order-function)]
+     (when-not (protoconcepts? ctx (base-set protoconcepts))
+       (illegal-argument "Given base-set and order-function do not describe protoconcepts in given context."))
+     protoconcepts)))
+
+(defn protoconcepts-order
+  "Returns for a given context ctx its protoconcepts with order."
+  [ctx]
+  (make-protoconcepts-nc (protoconcepts ctx)
+                         (fn <= [[A B] [C D]]
+                           (and (subset? A C)
+                                (subset? D B)))))

src/main/clojure/conexp/gui/draw.clj

@@ -28,7 +28,8 @@
   (:import [java.awt BorderLayout Dimension]
            [javax.swing BoxLayout JFrame JPanel JScrollBar JScrollPane]
            [conexp.fca.posets Poset]
-           [conexp.fca.lattices Lattice]))
+           [conexp.fca.lattices Lattice]
+           [conexp.fca.protoconcepts Protoconcepts]))
 
 ;;; Lattice Editor
 
@@ -120,6 +121,10 @@
   [layout]
   (JFrame. "conexp-clj Ordered Set"))
 
+(defmethod make-frame Protoconcepts
+  [layout]
+  (JFrame. "conexp-clj Protoconcepts"))
+
 ;;; Drawing Routine for the REPL
 (defn draw-layout
   "Draws given layout on a canvas. Returns the frame and the scene (as
@@ -130,7 +135,7 @@
     - dimension [600 600]
   "
   [layout
-   & {:keys [visible dimension]
+   & {:keys [visible dimension title]
       :or   {visible   true,
              dimension [600 600]}}]
   (let [frame          (make-frame layout),
@@ -142,21 +147,40 @@
     {:frame frame,
      :scene (get-scene-from-panel lattice-editor)}))
 
+(defn draw-poset
+  "Draws poset with given layout. Passes all other parameters to draw-layout."
+  [poset & args]
+  (let [map (apply hash-map args),
+        layout-fn (get map :layout-fn standard-layout),
+        value-fn (get map :value-fn (constantly nil))]
+    (apply draw-layout (-> poset layout-fn (to-valued-layout value-fn)) args)))
+
+(defn draw-protoconcepts
+  "Draws protoconcepts with given layout."
+  [protoconcepts & args]
+  (draw-poset protoconcepts args))
+
 (defn draw-lattice
   "Draws lattice with given layout. Passes all other parameters to
   draw-layout."
   [lattice & args]
-  (let [map       (apply hash-map args),
-        layout-fn (get map :layout-fn standard-layout)
-        value-fn (get map :value-fn (constantly nil))]
-    (apply draw-layout (-> lattice layout-fn (to-valued-layout value-fn)) args)))
+  (draw-poset lattice args))
 
 (defn draw-concept-lattice
   "Draws the concept lattice of a given context, passing all remaining
   args to draw-lattice."
   [ctx & args]
   (apply draw-lattice (concept-lattice ctx) args))
 
+(defn draw-protoconcepts
+  "Draws protoconcepts (ordered set) with given layout.
+  Passes all other parameters to draw-layout."
+  [protoconcepts & args]
+  (let [map       (apply hash-map args),
+        layout-fn (get map :layout-fn standard-layout)
+        value-fn (get map :value-fn (constantly nil))]
+    (apply draw-layout (-> protoconcepts layout-fn (to-valued-layout value-fn)) :title "conexp-clj Protoconcepts" args)))
+
 ;;;
 
 (defn draw-lattice-to-file

src/main/clojure/conexp/layouts/layered.clj

@@ -11,7 +11,10 @@
   (:use conexp.base
         conexp.math.algebra
         conexp.layouts.util
-        conexp.layouts.base))
+        conexp.layouts.base
+        conexp.math.algebra
+        conexp.fca.lattices
+        conexp.fca.protoconcepts))
 
 ;;; Simple Layered Layout
 

src/main/clojure/conexp/layouts/util.clj

@@ -11,11 +11,13 @@
   (:require [conexp.base :refer :all]
             [conexp.math.algebra :refer :all]
             [conexp.fca.lattices :refer :all]
+            [conexp.fca.protoconcepts :refer :all]
             [conexp.fca.posets :refer :all]
             [conexp.layouts.base :refer :all]
             [conexp.util.graph :as graph])
   (:import [conexp.fca.posets Poset]
-           [conexp.fca.lattices Lattice]))
+           [conexp.fca.lattices Lattice]
+           [conexp.fca.protoconcepts Protoconcepts]))
 
 ;;;
 
@@ -120,7 +122,7 @@
   are directly neighboured in poset."
   (fn [poset] (type poset)))
 
-(defmethod edges Poset
+(defn- poset-edges
   [poset]
   (into #{} 
         (filter #(directly-neighboured? poset (first %) (second %)) 
@@ -129,10 +131,18 @@
                       :when ((order poset) x y)]
                   [x y]))))
 
+(defmethod edges Poset
+  [poset]
+  (poset-edges poset))
+
 (defmethod edges Lattice
   [lattice]
   (edges-by-border lattice))
 
+(defmethod edges Protoconcepts
+  [protoconcepts]
+  (poset-edges protoconcepts))
+
 (defn top-down-elements-in-layout
   "Returns the elements in layout ordered top down."
   [layout]

src/test/clojure/conexp/fca/cover_test.clj

@@ -7,9 +7,11 @@
 ;; You must not remove this notice, or any other, from this software.
 
 (ns conexp.fca.cover-test
-  (:use conexp.fca.pqcores conexp.fca.cover
-        conexp.fca.contexts)
-  (:use conexp.fca.contexts)
+  (:use conexp.fca.pqcores
+        conexp.fca.cover
+        conexp.fca.contexts
+        conexp.fca.lattices
+        conexp.math.algebra)
   (:use clojure.test clojure.set))
 
 (deftest test-generate-cover
@@ -90,3 +92,4 @@
         new-cover (generate-cover (map last (concepts new-ctx)))]
     (is (= new-cover
            (cover-reducer cover ctx new-ctx 4)))))
+