mirror of
https://github.com/RAIRLab/Spectra.git
synced 2025-06-08 20:05:00 +00:00
153 lines
7.5 KiB
Common Lisp
153 lines
7.5 KiB
Common Lisp
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark -*-
|
|
;;; File: feature-vector.lisp
|
|
;;; The contents of this file are subject to the Mozilla Public License
|
|
;;; Version 1.1 (the "License"); you may not use this file except in
|
|
;;; compliance with the License. You may obtain a copy of the License at
|
|
;;; http://www.mozilla.org/MPL/
|
|
;;;
|
|
;;; Software distributed under the License is distributed on an "AS IS"
|
|
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
|
|
;;; License for the specific language governing rights and limitations
|
|
;;; under the License.
|
|
;;;
|
|
;;; The Original Code is SNARK.
|
|
;;; The Initial Developer of the Original Code is SRI International.
|
|
;;; Portions created by the Initial Developer are Copyright (C) 1981-2012.
|
|
;;; All Rights Reserved.
|
|
;;;
|
|
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
|
|
|
|
(in-package :snark)
|
|
|
|
(defconstant $fv-maximum-feature-value 999)
|
|
(defconstant $fv-features-per-symbol 10)
|
|
(defconstant $fv-offset-pos-count 0) ;number of occurrences in positive literals
|
|
(defconstant $fv-offset-neg-count 1) ;number of occurrences in negative literals
|
|
(defconstant $fv-offset-pos-max-depth 2) ;maximum depth of occurrences in positive literals
|
|
(defconstant $fv-offset-neg-max-depth 3) ;maximum depth of occurrences in negative literals
|
|
(defconstant $fv-offset-pos-min-depth 4) ;minimum depth of occurrences in positive literals (negated)
|
|
(defconstant $fv-offset-neg-min-depth 5) ;minimum depth of occurrences in negative literals (negated)
|
|
(defconstant $fv-number-ground 0) ;pseudo symbol-number for ground literal counts, doesn't match any actual symbol-number
|
|
|
|
(declare-snark-option feature-vector-symbol-number-folding 10 10)
|
|
|
|
(defun new-feature-vector ()
|
|
(make-sparse-vector :default-value 0))
|
|
|
|
(defun feature-vector-list (fv)
|
|
;; convert to list form suitable for input to trie.lisp operations
|
|
(let ((fv* nil))
|
|
(prog->
|
|
(map-sparse-vector-with-indexes fv :reverse t ->* v k)
|
|
(cl:assert (< 0 v))
|
|
(setf fv* (list* (fv-trie-key k v) fv*)))
|
|
fv*))
|
|
|
|
(defun update-feature-vector (symbol-number relation-symbol? arity polarity count depth fv)
|
|
(let* ((symbol-number* (let ((n (feature-vector-symbol-number-folding?)))
|
|
(if n
|
|
(+ (mod symbol-number n)
|
|
(if relation-symbol? ;fold relations and functions separately
|
|
(+ 1 (case arity (0 (* 1 n)) (1 (* 2 n)) (2 (* 3 n)) (otherwise (* 4 n))))
|
|
(+ 1 (case arity (0 (* 5 n)) (1 (* 6 n)) (2 (* 7 n)) (otherwise (* 8 n))))))
|
|
symbol-number)))
|
|
(base (* $fv-features-per-symbol symbol-number*))
|
|
(pos (ecase polarity (:pos t) (:neg nil))))
|
|
(cl:assert (and (<= 1 count) (<= 0 depth)))
|
|
(cond
|
|
(relation-symbol?
|
|
(let* ((count-index (+ base (if pos $fv-offset-pos-count $fv-offset-neg-count)))
|
|
(v (sparef fv count-index))
|
|
(v* (min $fv-maximum-feature-value (+ v count))))
|
|
(unless (= v v*)
|
|
(setf (sparef fv count-index) v*))))
|
|
(t
|
|
(let* ((max-depth-index (+ base (if pos $fv-offset-pos-max-depth $fv-offset-neg-max-depth)))
|
|
(v (sparef fv max-depth-index))
|
|
(v* (min $fv-maximum-feature-value (max v depth))))
|
|
(unless (= v v*)
|
|
(setf (sparef fv max-depth-index) v*)))
|
|
(cond
|
|
((test-option49?)
|
|
(let* ((count-index (+ base (if pos $fv-offset-pos-count $fv-offset-neg-count)))
|
|
(v (sparef fv count-index))
|
|
(v* (min $fv-maximum-feature-value (+ v count))))
|
|
(unless (= v v*)
|
|
(setf (sparef fv count-index) v*))))
|
|
(t
|
|
(let* ((min-depth-index (+ base (if pos $fv-offset-pos-min-depth $fv-offset-neg-min-depth)))
|
|
(v (sparef fv min-depth-index)) ;translate lower depths to higher feature values
|
|
(v* (max 1 (max v (- $fv-maximum-feature-value depth)))))
|
|
(unless (= v v*)
|
|
(setf (sparef fv min-depth-index) v*))
|
|
(cond
|
|
((and (= 0 v) (< 1 count))
|
|
(let ((count-index (+ base (if pos $fv-offset-pos-count $fv-offset-neg-count))))
|
|
(setf (sparef fv count-index) (min $fv-maximum-feature-value count))))
|
|
((< 0 v) ;don't store count for single occurrence
|
|
(let* ((count-index (+ base (if pos $fv-offset-pos-count $fv-offset-neg-count)))
|
|
(v (sparef fv count-index))
|
|
(v* (min $fv-maximum-feature-value (if (= 0 v) (+ 1 count) (+ v count)))))
|
|
(unless (= v v*)
|
|
(setf (sparef fv count-index) v*))))))))))
|
|
fv))
|
|
|
|
(defun clause-feature-vector (clause &optional subst (convert-to-list? t))
|
|
(let ((fv (new-feature-vector)))
|
|
(prog->
|
|
(map-atoms-in-clause clause ->* atom polarity)
|
|
(atom-feature-vector atom subst polarity fv)
|
|
(unless (test-option50?)
|
|
(when (ground-p atom subst)
|
|
(incf (sparef fv (+ $fv-number-ground (if (eq :pos polarity) $fv-offset-pos-count $fv-offset-neg-count)))))))
|
|
(if convert-to-list? (feature-vector-list fv) fv)))
|
|
|
|
(defun atom-or-term-feature-vector (x &optional subst (convert-to-list? t))
|
|
(let ((fv (new-feature-vector)))
|
|
(if (dereference
|
|
x subst
|
|
:if-constant (constant-boolean-valued-p x)
|
|
:if-compound-appl (function-boolean-valued-p (heada x)))
|
|
(atom-feature-vector x subst :pos fv)
|
|
(term-feature-vector x subst :pos 0 fv))
|
|
(if convert-to-list? (feature-vector-list fv) fv)))
|
|
|
|
(defun atom-feature-vector (atom &optional subst (polarity :pos) (fv (new-feature-vector)))
|
|
(dereference
|
|
atom subst
|
|
:if-constant (update-feature-vector (constant-number atom) t 0 polarity 1 0 fv)
|
|
:if-compound (progn
|
|
(update-feature-vector (function-number (head atom)) t (function-arity (head atom)) polarity 1 0 fv)
|
|
(mapc #'(lambda (arg) (term-feature-vector arg subst polarity 0 fv)) (args atom))))
|
|
fv)
|
|
|
|
(defun term-feature-vector (term &optional subst (polarity :pos) (depth 0) (fv (new-feature-vector)))
|
|
;; in (p a (f b)), depth(p)=depth(a)=depth(f)=0, depth(b)=1
|
|
;; compute count of associative function symbols as if term is in unflattened form
|
|
;; count(f)=2 for f(a,b,c)
|
|
;; compute depth of terms with associatve function symbols as if term is in flattened form
|
|
;; depth(a)=1 for f(f(a,b),c)
|
|
(labels
|
|
((tfv (term depth)
|
|
(dereference
|
|
term subst
|
|
:if-constant (update-feature-vector (constant-number term) nil 0 polarity 1 depth fv)
|
|
:if-compound (prog->
|
|
(head term -> head)
|
|
(args term -> args)
|
|
(if (function-associative head) head nil -> head-if-associative)
|
|
(if head-if-associative
|
|
(update-feature-vector (function-number head) nil (function-arity head) polarity (max (- (length args) 1) 1) depth fv)
|
|
(update-feature-vector (function-number head) nil (function-arity head) polarity 1 depth fv))
|
|
(mapc #'(lambda (arg)
|
|
(if (and head-if-associative
|
|
(dereference
|
|
arg subst
|
|
:if-compound (and head-if-associative (eq head-if-associative (head arg)))))
|
|
(tfv arg depth)
|
|
(tfv arg (+ depth 1))))
|
|
args)))))
|
|
(tfv term depth))
|
|
fv)
|
|
|
|
;;; feature-vector.lisp EOF
|