 (ns conexp.fca.lattices
   (:use conexp.base
-	[conexp.fca.contexts :only (concepts)])
+	conexp.fca.contexts)
   (:gen-class
    :name "conexp.fca.Lattice"
    :prefix "Lattice-"
    :init init
-   :constructors { [ Object Object ] [] }
+   :constructors { [ Object Object ] []            ; relational lattices (<=)
+		   [ Object Object Object ] [] }   ; functional lattices (inf, sup)
    :state state))
 
-(defn Lattice-init [base-set order]
-  [ [] {:base-set base-set :order order} ])
+;;; Datastructure
+
+(defn Lattice-init
+  ([base-set order]
+     [ [] {:base-set base-set, :order order, :inf nil, :sup nil} ])
+  ([base-set inf sup]
+     [ [] {:base-set base-set, :order nil,   :inf inf, :sup sup} ]))
 
 (defn base-set [lattice]
   ((.state lattice) :base-set))
 
 (defn order [lattice]
-  ((.state lattice) :order))
+  (or ((.state lattice) :order)
+      (let [sup ((.state lattice) :sup)]
+	(set-of [x y] [x (base-set lattice)
+		       y (base-set lattice)
+		       :when (= y (sup x y))]))))
+
+(defn inf [lattice]
+  (or ((.state lattice) :inf)
+      (let [order (order lattice)
+	    base  (base-set lattice)]
+	(fn [x y]
+	  (first (set-of z [z base
+			    :when (and (order [z x])
+				       (order [z y])
+				       (forall [a base]
+					       (=> (and (order [a x]) (order [a y]))
+						   (order [a z]))))]))))))
+
+(defn sup [lattice]
+  (or ((.state lattice) :sup)
+      (let [order (order lattice)
+	    base  (base-set lattice)]
+	(fn [x y]
+	  (first (set-of z [z base
+			    :when (and (order [x z])
+				       (order [y z])
+				       (forall [a base]
+					       (=> (and (order [x a]) (order [y a]))
+						   (order [z a]))))]))))))
 
 (defn Lattice-toString [this]
   (str "Lattice on " (count (base-set this)) " elements."))

	 (inf (sup x y) (sup x z))))))

(defn modular? [lat]
  (let [inf  (partial inf lat)
	sup  (partial sup lat)
	base (base-set lat)
	ordr (order lat)]
    (forall [x base

  (intersection (lattice-sup-irreducibles lat)
		(lattice-inf-irreducibles lat)))


;;; FCA

(defn concept-lattice [ctx]
  (make-lattice (concepts ctx) 
		(fn [[A _] [X _]] 
		  (subset? A X))))

(defn standard-context [lat]
  (make-context (lattice-sup-irreducibles lat)
		(lattice-inf-irreducibles lat)
		(order lat)))