bar.clj

(ns Archimedes.bar
  (:refer-clojure :exclude [==])
  (:require [clojure.core.logic :refer :all]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; databaseo
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def types
  {:long {:primitive true
          :natural true
          :fixed-width true}
   :double {:primitive true
            :floating-point true
            :fixed-width true}
   :Long {:boxed :long
          :object true
          :natural true
          :fixed-width true}
   :Double {:boxed :double
            :object true
            :floating-point true
            :fixed-width true}
   :float {:primitive true
           :floating-point true
           :fixed-width true}
   :Float {:boxed :float
           :object true
           :floating-point true
           :fixed-width true}
   :int {:primitive true
         :natural true
         :fixed-width true}
   :Integer {:boxed :int
             :object true
             :natural true
             :fixed-width true}
   :Ratio {:boxed false}
   :Number {:boxed false}
   :Object {:boxed false}
   :BigDecimal {:boxed false
                :floating-point true}
   :BigInteger {:boxed false
                :natural true}
   :BigInt {:boxed false
            :natural true}})

(def operations
  {:add {:arity 2}
   :subtract {:arity 2}
   :zero? {:arity 1
           :return :boolean}
   :neg {:arity 1}
   :divide {:arity 2}
   :multiply {:arity 2}
   })

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; predicates

(defn binaryo [op]
  (fn [s]
    (let [op (get (.s s) op)
          {:keys [arity]} (get operations op)]
      (when (= 2 arity)
        s))))

(defn unaryo [op]
  (fn [s]
    (let [op (get (.s s) op)
          {:keys [arity]} (get operations op)]
      (when (= 1 arity)
        s))))

(defn returno [op]
  (fn [s]
    (let [op (get (.s s) op)
          {:keys [return]} (get operations op)]
      (when return
        s))))

(defn not-boxedo [type]
  (fn [s]
    (let [type (get (.s s) type)
          {:keys [boxed]} (get types type)]
      (when-not boxed
        s))))

(defn boxedo [type]
  (fn [s]
    (let [type (get (.s s) type)
          {:keys [boxed]} (get types type)]
      (when boxed
        s))))

(defn floating-pointo [type]
  (fn [s]
    (let [type (get (.s s) type)
          {:keys [floating-point]} (get types type)]
      (when floating-point
        s))))

(defn not-floating-pointo [type]
  (fn [s]
    (let [type (get (.s s) type)
          {:keys [floating-point]} (get types type)]
      (when-not floating-point
        s))))

(defn naturalo [type]
  (fn [s]
    (let [type (get (.s s) type)
          {:keys [natural]} (get types type)]
      (when natural
        s))))

(defn not-naturalo [type]
  (fn [s]
    (let [type (get (.s s) type)
          {:keys [natural]} (get types type)]
      (when-not natural
        s))))

(defn fixed-widtho [type]
  (fn [s]
    (let [type (get (.s s) type)
          {:keys [fixed-width]} (get types type)]
      (when fixed-width
        s))))

(defn not-fixed-widtho [type]
  (fn [s]
    (let [type (get (.s s) type)
          {:keys [fixed-width]} (get types type)]
      (when-not fixed-width
        s))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn sameo [arg1 arg2 return]
  (conde
   [(== arg1 arg2) (== arg1 :int) (== return :long)]
   [(== arg1 arg2) (== arg1 :float) (== return :double)]
   [(== arg1 arg2) (boxedo arg1) (not-boxedo return)]
   [(== arg1 arg2) (not-boxedo arg1) (== arg1 return)]
   [(!= arg1 arg2)]))

(defn floating-point-contaminato [arg1 arg2 return]
  (conde
   [(floating-pointo arg1) (floating-pointo arg2) (floating-pointo return)]
   [(floating-pointo arg1) (not-floating-pointo arg2) (floating-pointo return)]
   [(not-floating-pointo arg1) (floating-pointo arg2) (floating-pointo return)]
   [(not-floating-pointo arg1) (not-floating-pointo arg2) (not-floating-pointo return)]))

(defn ratio-contaminato [arg1 arg2 return]
  (conde
   [(== arg1 :Ratio) (== arg2 :Ratio) (== return :Ratio)]
   [(floating-pointo arg1) (== arg2 :Ratio) (floating-pointo return)]
   [(== arg1 :Ratio) (floating-pointo arg2) (floating-pointo return)]
   [(not-floating-pointo arg1) (== arg2 :Ratio) (== return :Ratio)]
   [(== arg1 :Ratio) (not-floating-pointo arg2) (== return :Ratio)]
   [(!= arg1 :Ratio) (!= arg2 :Ratio)]))

(defn object-contaminato [arg1 arg2 return]
  (conde
   [(== arg1 :Object) (== arg2 :Object) (== return :Number)]
   [(!= arg1 :Object) (== arg2 :Object) (== return :Number)]
   [(== arg1 :Object) (!= arg2 :Object) (== return :Number)]
   [(!= arg1 :Object) (!= arg2 :Object)]))

(defn number-contaminato [arg1 arg2 return]
  (conde
   [(== arg1 :Number) (== arg2 :Number) (== return :Number)]
   [(!= arg1 :Number) (== arg2 :Number) (== return :Number)]
   [(== arg1 :Number) (!= arg2 :Number) (== return :Number)]
   [(!= arg1 :Number) (!= arg2 :Number)]))

(defn bigdecimal-contaminato [arg1 arg2 return]
  (conde
   [(== arg1 :BigDecimal) (== arg2 :BigDecimal) (== return :BigDecimal)]
   [(!= arg1 :BigDecimal) (== arg2 :BigDecimal) (== return :BigDecimal)]
   [(== arg1 :BigDecimal) (!= arg2 :BigDecimal) (== return :BigDecimal)]
   [(!= arg1 :BigDecimal) (!= arg2 :BigDecimal)]))

(defn special-diviso [op arg1 arg2 return]
  (conde
   [(== op :divide) (floating-pointo arg1) (floating-pointo arg2) (floating-pointo return)]
   [(== op :divide) (floating-pointo arg1) (not-floating-pointo arg2) (floating-pointo return)]
   [(== op :divide) (not-floating-pointo arg1) (floating-pointo arg2) (floating-pointo return)]
   [(== op :divide) (not-floating-pointo arg1) (not-floating-pointo arg2) (== return :Ratio)]
   [(!= op :divide)]))

(defn constrain-returno [return]
  (fresh
   []
   (!= return :float)
   (!= return :int)
   (!= return :Object)
   (!= return :BigInteger)
   (not-boxedo return)))

(defn setupo [q op arg1 arg2 return]
  (fresh
   []
   (== q [op arg1 arg2 return])
   (membero op (keys operations))
   (membero arg1 (keys types))
   (membero arg2 (keys types))
   (membero return (keys types))))

(defn fixed-width-cantaminato [op arg1 arg2 return]
  (conde
   [(!= :divide op) (fixed-widtho arg1) (fixed-widtho arg2) (fixed-widtho return)]
   [(!= :divide op) (not-fixed-widtho arg1) (fixed-widtho arg2) (not-fixed-widtho return)]
   [(!= :divide op) (fixed-widtho arg1) (not-fixed-widtho arg2) (not-fixed-widtho return)]
   [(!= :divide op) (not-fixed-widtho arg1) (not-fixed-widtho arg2) (not-fixed-widtho return)]
   [(== :divide op) (fixed-widtho arg1) (fixed-widtho arg2)
    (conde
     [(floating-pointo arg1) (floating-pointo arg2) (fixed-widtho return)]
     [(floating-pointo arg1) (not-floating-pointo arg2) (fixed-widtho return)])]))

(defn f []
  (run*
   [q]
   (fresh
    [op arg1 arg2 return]
    (setupo q op arg1 arg2 return)
    (binaryo op)
    (constrain-returno return)
    (sameo arg1 arg2 return)
    (floating-point-contaminato arg1 arg2 return)
    (ratio-contaminato arg1 arg2 return)
    (object-contaminato arg1 arg2 return)
    (number-contaminato arg1 arg2 return)
    (bigdecimal-contaminato arg1 arg2 return)
    (special-diviso op arg1 arg2 return)
    (fixed-width-cantaminato op arg1 arg2 return)
    (conde
     [(!= :divide op) (naturalo arg1) (naturalo arg2) (naturalo return)]
     [(!= :divide op) (not-naturalo arg1) (naturalo arg2) (not-naturalo return)]
     [(!= :divide op) (naturalo arg1) (not-naturalo arg2) (not-naturalo return)]
     [(== :divide op)])
    )))