   (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)))
    (seq? thing) ::seq
    :else        ::invalid))

(defmulti make-lattice (fn [base-set order] [(type-of base-set) (type-of order)]))

(defmethod make-lattice [::set ::set] [base-set order]
  (conexp.fca.Lattice. base-set (union (set-of [x x] [x base-set])
				       (transitive-closure order))))

(defmethod make-lattice [::set ::fn] [base-set order2]
  (make-lattice base-set (set-of [x y] [x base-set y base-set :when (order2 x y)])))

(defmethod make-lattice :default [base-set order]
  (illegal-argument "The arguments " base-set " and " order " are not valid for a Lattice."))

(defn inf [lat x y]
  (let [order (order lat)
	base  (base-set lat)]
    (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 [lat x y]
  (let [order (order lat)
	base  (base-set lat)]
    (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 dual-lattice [lat]
  (make-lattice (base-set lat) (set-of [y x] [[x y] (order lat)])))

(defn distributive? [lat]
  (let [inf  (partial inf lat)
	sup  (partial sup lat)
	base (base-set lat)]
    (forall [x base
	     y base

(ns conexp.fca.lattices
  (:use conexp.base
	conexp.fca.contexts)
  (:gen-class
   :name "conexp.fca.Lattice"
   :prefix "Lattice-"
   :init init
   :constructors { [ Object Object ] []            ; relational lattices (<=)
		   [ Object Object Object ] [] }   ; functional lattices (inf, sup)
   :state state))

;;; 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]
  (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."))
