├── asd-generator-data.asd ├── .gitignore ├── circle.yml ├── testscr.ros ├── cl-sat.test.asd ├── src ├── 0-package.lisp ├── 2-class.lisp ├── 1-util.lisp ├── 4-competition.lisp ├── 3-dimacs.lisp └── 1-parse.lisp ├── .travis.yml ├── cl-sat.asd ├── competition.org ├── t ├── package.lisp ├── plaidctf-2015.lisp └── competitions.lisp └── README.org /asd-generator-data.asd: -------------------------------------------------------------------------------- 1 | 2 | ((#:src (:rest))) 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *.fasl 3 | *.dx32fsl 4 | *.dx64fsl 5 | *.lx32fsl 6 | *.lx64fsl 7 | *.x86f 8 | *~ 9 | .#* 10 | *.backup 11 | solvers/2016/ 12 | solvers/2017/ 13 | solvers/2018/ 14 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | machine: 2 | environment: 3 | PATH: ~/.roswell/bin:$PATH 4 | 5 | dependencies: 6 | pre: 7 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/master/scripts/install-for-ci.sh | sh 8 | - ros install ccl-bin 9 | cache_directories: 10 | - ~/.roswell/ 11 | 12 | test: 13 | override: 14 | - ros -L sbcl-bin testscr.ros 15 | - ros -L ccl-bin testscr.ros 16 | -------------------------------------------------------------------------------- /testscr.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | 7 | (ql:quickload :fiveam) 8 | 9 | (defun main (&rest argv) 10 | (declare (ignorable argv)) 11 | (uiop:quit (if (handler-case 12 | (progn 13 | (ql:quickload :cl-sat.test) 14 | (eval (read-from-string "(5am:run! :cl-sat)"))) 15 | (serious-condition (c) 16 | (describe c) 17 | (uiop:quit 2))) 18 | 0 1))) 19 | -------------------------------------------------------------------------------- /cl-sat.test.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of cl-sat project. 3 | Copyright (c) 2016 Masataro Asai (guicho2.71828@gmail.com) 4 | |# 5 | 6 | 7 | (defsystem cl-sat.test 8 | :author "Masataro Asai" 9 | :mailto "guicho2.71828@gmail.com" 10 | :description "Test system of cl-sat" 11 | :license "LLGPL" 12 | :depends-on (:cl-sat 13 | :fiveam) 14 | :components ((:module "t" 15 | :components 16 | ((:file "package")))) 17 | :perform (test-op :after (op c) (eval (read-from-string "(5am:run! :cl-sat)")) 18 | )) 19 | -------------------------------------------------------------------------------- /src/0-package.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of cl-sat project. 3 | Copyright (c) 2016 Masataro Asai (guicho2.71828@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage cl-sat 8 | (:nicknames :sat) 9 | (:use :cl :trivia :alexandria :iterate) 10 | (:export 11 | #:solve 12 | #:sat-instance 13 | #:print-cnf 14 | #:with-temp 15 | #:*instance* 16 | #:variables 17 | #:to-nnf 18 | #:to-cnf 19 | #:to-cnf-naive 20 | #:to-cnf-tseytin 21 | #:symbolicate-form 22 | #:*verbosity* 23 | #:parse-dimacs-output 24 | #:imply 25 | #:=> 26 | #:iff 27 | #:<=> 28 | #:xor 29 | #:var 30 | #:aux 31 | #:simplify-nnf 32 | #:to-anf 33 | #:expand-extensions 34 | #:parse-assignments)) 35 | (in-package :cl-sat) 36 | 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: false 3 | 4 | addons: 5 | apt: 6 | packages: 7 | - libc6-i386 8 | - clisp 9 | 10 | env: 11 | global: 12 | - PATH=~/.roswell/bin:$PATH 13 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 14 | matrix: 15 | - LISP=sbcl-bin 16 | - LISP=ccl-bin 17 | - LISP=abcl 18 | - LISP=clisp 19 | - LISP=ecl 20 | - LISP=cmucl 21 | - LISP=alisp 22 | 23 | matrix: 24 | allow_failures: 25 | - env: LISP=clisp 26 | - env: LISP=abcl 27 | - env: LISP=ecl 28 | - env: LISP=cmucl 29 | - env: LISP=alisp 30 | 31 | install: 32 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/release/scripts/install-for-ci.sh | sh 33 | 34 | cache: 35 | directories: 36 | - $HOME/.roswell 37 | - $HOME/.config/common-lisp 38 | 39 | script: 40 | - ./testscr.ros 41 | -------------------------------------------------------------------------------- /cl-sat.asd: -------------------------------------------------------------------------------- 1 | ;;;; Autogenerated ASD file for system "CL-SAT" 2 | ;;;; In order to regenerate it, run update-asdf from shell (see https://github.com/phoe-krk/asd-generator) 3 | ;;;; For those who do not have update-asdf, run `ros install asd-generator` (if you have roswell installed) 4 | ;;;; There are also an interface available from lisp: (asd-generator:regen &key im-sure) 5 | 6 | (defsystem cl-sat 7 | :version "0.1" 8 | :author "Masataro Asai" 9 | :mailto "guicho2.71828@gmail.com" 10 | :license "LLGPL" 11 | :depends-on (:trivia :alexandria :iterate 12 | :trivial-features) 13 | :serial t 14 | :components ((:file "src/0-package") 15 | (:file "src/1-parse") 16 | (:file "src/1-util") 17 | (:file "src/2-class") 18 | (:file "src/3-dimacs") 19 | (:file "src/4-competition")) 20 | :description "Common Lisp API to Boolean SAT Solvers" 21 | :in-order-to ((test-op (test-op :cl-sat.test)))) 22 | -------------------------------------------------------------------------------- /src/2-class.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-sat) 2 | 3 | (defclass sat-instance () 4 | ((cnf :reader cnf :initarg :cnf) 5 | (%variables))) 6 | 7 | (defgeneric solve (input solver-designator &rest args)) 8 | 9 | (defmethod initialize-instance ((i sat-instance) &rest args &key form cnf (converter #'to-cnf-tseytin) &allow-other-keys) 10 | (assert (not (and form cnf)) nil ) 11 | (cond 12 | ((and form cnf) 13 | (error "incompatible keywords: :form and :cnf specified at the same time")) 14 | (form 15 | (remf args :form) 16 | (apply #'call-next-method i :cnf (to-cnf form converter) args)) 17 | (t 18 | (call-next-method)))) 19 | 20 | (defvar *instance*) 21 | 22 | (defmethod solve ((*instance* sat-instance) solver &rest args &key debug &allow-other-keys) 23 | ;; Remove sat-instance initargs so they aren't passed to command line 24 | (remf args :form) 25 | (remf args :cnf) 26 | (remf args :converter) 27 | 28 | (with-temp (tmp :template "cnf.XXXXXXX" :debug debug) 29 | (with-output-to-file (s tmp :if-exists :supersede) 30 | (print-cnf *instance* s)) 31 | (apply #'solve (pathname tmp) solver args))) 32 | 33 | (defmethod solve ((i list) solver &rest args &key (converter #'to-cnf-tseytin) &allow-other-keys) 34 | (apply #'solve 35 | (make-instance 'sat-instance :form i :converter converter) 36 | solver 37 | args)) 38 | 39 | 40 | (defgeneric variables (instance)) 41 | (defmethod variables :around ((instance sat-instance)) 42 | (with-slots (%variables) instance 43 | (if (slot-boundp instance '%variables) 44 | %variables 45 | (setf %variables 46 | (coerce 47 | (call-next-method) 48 | 'simple-vector))))) 49 | 50 | (defmethod variables ((instance sat-instance)) 51 | (remove-duplicates 52 | (set-difference 53 | (flatten (cnf instance)) 54 | '(and or not)))) 55 | 56 | -------------------------------------------------------------------------------- /src/1-util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-sat) 2 | 3 | ;; These constants are borrowed from the tempname utility 4 | ;; of coreutils. 5 | (defparameter +random-string-size-min+ 3) 6 | (defparameter +temp-file-attempts+ (* 62 62 62)) 7 | 8 | (defmacro with-temp ((var &key directory (template "tmp.XXXXXXX") (tmpdir `(uiop:temporary-directory)) debug) &body body) 9 | "Create a temporary file, then remove the file by unwind-protect. 10 | Most arguments are analogous to mktemp. 11 | TEMPLATE should be a string that ends with one or more X's, these X's will be replaced by random characters. 12 | When DIRECTORY is non-nil, creates a directory instead. 13 | When DEBUG is non-nil, it does not remove the directory so that you can investigate what happened inside the directory. 14 | An error of type file-error is signalled if a unique file name can't be generated after a number of attempts." 15 | (declare (ignorable template tmpdir)) 16 | (once-only (template tmpdir directory debug) 17 | `(let ((,var 18 | (let* ((template-without-xs (string-right-trim "X" ,template))) 19 | (attempt-create-temp ,directory 20 | ,tmpdir 21 | template-without-xs 22 | (- (length ,template) (length template-without-xs)) 23 | +temp-file-attempts+)))) 24 | (unwind-protect 25 | (progn ,@body) 26 | (if ,debug 27 | (format t "~¬ removing ~a for debugging" ,var) 28 | (if ,directory 29 | (uiop:delete-directory-tree (make-pathname :directory (list :absolute ,var)) 30 | :if-does-not-exist :ignore 31 | :validate t) 32 | (delete-file ,var))))))) 33 | 34 | (defun attempt-create-temp (directory base-dir name-prefix random-string-size attempts) 35 | "Creates a file/directory in BASE-DIR with NAME-PREFIX as a prefix of the name and RANDOM-STRING-SIZE 36 | random base62 characters at the end. 37 | If DIRECTORY is non-nil, creates a directory. 38 | Returns the name of the created file. 39 | Signals an error if it can't generate a unique name after ATTEMPTS attempts." 40 | (when (> +random-string-size-min+ random-string-size) 41 | (error "Random string part of temporary file name isn't long enough.")) 42 | (if (<= attempts 0) 43 | (error "Couldn't create a unique temp file/folder.") 44 | (let ((path (merge-pathnames (let ((name (generate-temp-name name-prefix random-string-size))) 45 | (if directory 46 | (make-pathname :directory `(:relative ,name)) 47 | (uiop:parse-unix-namestring name))) 48 | (uiop:parse-unix-namestring base-dir)))) 49 | (if (create-nonexisting directory path) 50 | (namestring path) 51 | (attempt-create-temp directory base-dir name-prefix random-string-size (1- attempts)))))) 52 | 53 | (defun generate-temp-name (name-prefix random-string-size) 54 | "Generates a random name for a temp file/directory. 55 | NAME-PREFIX is the prefix of the name, after which RANDOM-STRING-SIZE random characters are added. " 56 | (concatenate 'string name-prefix (random-base62 random-string-size))) 57 | 58 | (defun random-base62 (n) 59 | "Returns a random base62 string with n characters." 60 | (let ((table "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")) 61 | (coerce (loop repeat n collect (aref table (random (length table)))) 62 | 'string))) 63 | 64 | (defun create-nonexisting (directory path) 65 | "Attempts to create a file/directory, returns NIL if it exists already and T otherwise." 66 | (handler-case 67 | (if directory 68 | (multiple-value-bind (_ was-nonexisting) (ensure-directories-exist path) 69 | (declare (ignore _)) 70 | was-nonexisting) 71 | (progn 72 | (open path 73 | :direction :io 74 | :if-exists :error) 75 | t)) 76 | (file-error (_) 77 | (declare (ignore _)) 78 | nil))) 79 | 80 | (defun format1 (stream format-control first-arg &rest more-args) 81 | (apply #'format stream format-control first-arg more-args) 82 | first-arg) 83 | -------------------------------------------------------------------------------- /src/4-competition.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :cl-sat) 3 | 4 | (defvar *base-url* 5 | `((2016 . "https://baldur.iti.kit.edu/sat-competition-2016/solvers/") 6 | (2017 . "https://baldur.iti.kit.edu/sat-competition-2017/solvers/") 7 | (2018 . "http://sat2018.forsyte.tuwien.ac.at/solvers/") 8 | (2019 . "http://sat-race-2019.ciirc.cvut.cz/solvers/"))) 9 | 10 | (define-condition competition-setup-error (error) 11 | ((year :initarg :year) 12 | (track :initarg :track) 13 | (name :initarg :name)) 14 | (:report 15 | (lambda (c s) 16 | (print c s)))) 17 | 18 | (defmethod print-object ((c competition-setup-error) s) 19 | (print-unreadable-object (c s :type t) 20 | (with-slots (year track name) c 21 | (format s "~a ~a ~a" year track name)))) 22 | 23 | (define-condition download-error (competition-setup-error) ()) 24 | (define-condition unzip-error (competition-setup-error) ()) 25 | (define-condition build-error (competition-setup-error) ()) 26 | (define-condition chmod-error (competition-setup-error) ()) 27 | 28 | (defun download-solver (year track name) 29 | (check-type year fixnum) 30 | (let* ((dir (namestring (asdf:system-relative-pathname :cl-sat (format nil "solvers/~a/~a/" year track)))) 31 | (zip (namestring (merge-pathnames (format nil "~a.zip" name) dir))) 32 | (runner (namestring (merge-pathnames (format nil "~a/bin/starexec_run_default" name) dir))) 33 | (bin (namestring (merge-pathnames (format nil "~a/bin/" name) dir))) 34 | (home (namestring (merge-pathnames (format nil "~a/" name) dir)))) 35 | (ensure-directories-exist zip) 36 | (unless (probe-file runner) 37 | (alexandria:unwind-protect-case () 38 | (progn 39 | (handler-case 40 | (uiop:run-program `("wget" ,(format nil "~a/~a/~a.zip" (cdr (assoc year *base-url*)) track name) "-O" ,zip) 41 | :output t :error t) 42 | (uiop:subprocess-error () 43 | (error 'download-error :year year :track track :name name))) 44 | (handler-case 45 | (uiop:run-program `("sh" "-c" ,(format nil "cd ~a; unzip ~a.zip" dir name)) 46 | :output t :error t) 47 | (uiop:subprocess-error () 48 | (error 'unzip-error :year year :track track :name name))) 49 | (handler-case 50 | (uiop:run-program `("sh" "-c" ,(format nil "cd ~a; chmod +x starexec_build build/*; MAKEFLAGS=\"-j 4\" ./starexec_build" home)) 51 | :output t :error t) 52 | (uiop:subprocess-error () 53 | (error 'build-error :year year :track track :name name)))) 54 | (:abort 55 | (format *error-output* "~&Aborting, cleaning up~%") 56 | (uiop:run-program `("rm" "-rv" ,zip ,home) 57 | :output t :error t :ignore-error-status t)))) 58 | (unless (probe-file runner) 59 | (error "Runner script ~a is missing in ~a !" runner bin)) 60 | (handler-case 61 | (uiop:run-program `("sh" "-c" ,(format nil "chmod +x ~a/*" bin)) 62 | :output t :error-output t) 63 | (uiop:subprocess-error () 64 | (error 'chmod-error :year year :track track :name name))) 65 | (values runner bin))) 66 | 67 | (defmethod solve ((input pathname) (competition (eql :competition)) &rest options &key debug year track name &allow-other-keys) 68 | (remf options :debug) 69 | (remf options :solver) 70 | 71 | (with-temp (dir :directory t :template "glucose.XXXXXXXX" :debug debug) 72 | (multiple-value-bind (runner bin) (download-solver year track name) 73 | (let* ((command (format nil "cd ~a ; bash ~a ~a ~a" 74 | bin 75 | runner 76 | (namestring input) 77 | (namestring dir))) 78 | (result (format nil "~a/result" dir))) 79 | (format t "~&; ~a" command) 80 | (multiple-value-match (uiop:run-program command 81 | :output result 82 | :error-output t 83 | :ignore-error-status t) 84 | ((_ _ 0) 85 | ;; indeterminite 86 | (values nil nil nil)) 87 | ((_ _ 10) 88 | ;; sat 89 | (parse-dimacs-output result *instance*)) 90 | ((_ _ 20) 91 | ;; unsat 92 | (values nil nil t))))))) 93 | -------------------------------------------------------------------------------- /competition.org: -------------------------------------------------------------------------------- 1 | 2 | + List of competition solvers that compiled: 100 3 | + List of competition solvers that worked (produced a conforming output): 52 4 | 5 | #+begin_src 6 | solvers/2016/agile/CHBR_glucose_agile.zip 7 | solvers/2016/agile/CHBR_glucose_tuned_agile.zip 8 | solvers/2016/agile/MapleGlucose.zip 9 | solvers/2016/agile/abcdSAT_drup.zip 10 | solvers/2016/agile/glucosePLE.zip 11 | solvers/2016/agile/glucose_hack_kiel_newScript.zip 12 | solvers/2016/agile/glue_alt.zip 13 | solvers/2016/agile/gulch-agile.zip 14 | solvers/2016/agile/gulch-once.zip 15 | solvers/2016/agile/tb_glucose_agile.zip 16 | solvers/2016/agile/tc_glucose_agile.zip 17 | solvers/2016/main/CHBR_glucose.zip 18 | solvers/2016/main/CHBR_glucose_tuned.zip 19 | solvers/2016/main/Glucose_nbSat.zip 20 | solvers/2016/main/MapleGlucose.zip 21 | solvers/2016/main/Scavel_SAT.zip 22 | solvers/2016/main/abcdSAT_drup.zip 23 | solvers/2016/main/drat-trim.zip 24 | solvers/2016/main/glucose.zip 25 | solvers/2016/main/glucosePLE.zip 26 | solvers/2016/main/glucose_hack_kiel_newScript.zip 27 | solvers/2016/main/glue_alt.zip 28 | solvers/2016/main/gulch.zip 29 | solvers/2016/main/tb_glucose.zip 30 | solvers/2016/main/tc_glucose.zip 31 | solvers/2016/random/CSCCSat.zip 32 | solvers/2016/random/DCCAlm.zip 33 | solvers/2016/random/multi-sat.zip 34 | solvers/2016/random/polypower1.0.zip 35 | solvers/2016/random/polypower2.0.zip 36 | solvers/2016/random/stocBCD.zip 37 | solvers/2017/agile/abcdsat_a17.zip 38 | solvers/2017/agile/abcdsat_r17.zip 39 | solvers/2017/agile/bs_glucose.zip 40 | solvers/2017/agile/cadical-sc17-agile.zip 41 | solvers/2017/agile/cadical-sc17-noproof.zip 42 | solvers/2017/agile/glu_vc.zip 43 | solvers/2017/agile/glucose-4.1.zip 44 | solvers/2017/agile/lingeling-bbe.zip 45 | solvers/2017/agile/tch_glucose1.zip 46 | solvers/2017/agile/tch_glucose2.zip 47 | solvers/2017/agile/tch_glucose3.zip 48 | solvers/2017/agile/yalsat-03s.zip 49 | solvers/2017/main/COMiniSatPS_Pulsar_drup.zip 50 | solvers/2017/main/GHackCOMSPS_drup.zip 51 | solvers/2017/main/MapleCOMSPS_CHB_VSIDS_drup.zip 52 | solvers/2017/main/MapleCOMSPS_LRB_VSIDS_2_drup.zip 53 | solvers/2017/main/MapleCOMSPS_LRB_VSIDS_drup.zip 54 | solvers/2017/main/MapleLRB_LCM.zip 55 | solvers/2017/main/MapleLRB_LCMoccRestart.zip 56 | solvers/2017/main/Maple_LCM.zip 57 | solvers/2017/main/Maple_LCM_Dist.zip 58 | solvers/2017/main/abcdsat_r17.zip 59 | solvers/2017/main/bs_glucose.zip 60 | solvers/2017/main/cadical-sc17-agile-proof.zip 61 | solvers/2017/main/cadical-sc17-proof.zip 62 | solvers/2017/main/glu_vc.zip 63 | solvers/2017/main/glucose-3.0+width.zip 64 | solvers/2017/main/glucose-4.1.zip 65 | solvers/2017/main/lingeling-bbe.zip 66 | solvers/2017/main/tch_glucose1.zip 67 | solvers/2017/main/tch_glucose2.zip 68 | solvers/2017/main/tch_glucose3.zip 69 | solvers/2017/random/Score2SAT.zip 70 | solvers/2017/random/tch_glucose3.zip 71 | solvers/2017/random/yalsat-03s.zip 72 | solvers/2018/main_and_glucose_hack/COMiniSatPS_Pulsar_drup.zip 73 | solvers/2018/main_and_glucose_hack/GHackCOMSPS_drup.zip 74 | solvers/2018/main_and_glucose_hack/Glucose_Hack_Kiel_fastBVE.zip 75 | solvers/2018/main_and_glucose_hack/Lingeling.zip 76 | solvers/2018/main_and_glucose_hack/MapleCOMSPS_CHB_VSIDS_drup.zip 77 | solvers/2018/main_and_glucose_hack/MapleCOMSPS_LRB_VSIDS_drup.zip 78 | solvers/2018/main_and_glucose_hack/MapleLCMDistChronoBT.zip 79 | solvers/2018/main_and_glucose_hack/Maple_CM.zip 80 | solvers/2018/main_and_glucose_hack/Maple_CM_Dist.zip 81 | solvers/2018/main_and_glucose_hack/Maple_CM_ordUIP+.zip 82 | solvers/2018/main_and_glucose_hack/Maple_CM_ordUIP.zip 83 | solvers/2018/main_and_glucose_hack/Maple_LCM+BCrestart.zip 84 | solvers/2018/main_and_glucose_hack/Maple_LCM+BCrestart_M1.zip 85 | solvers/2018/main_and_glucose_hack/Maple_LCM_M1.zip 86 | solvers/2018/main_and_glucose_hack/Minisat-v2.2.0-106-ge2dd095.zip 87 | solvers/2018/main_and_glucose_hack/YalSAT.zip 88 | solvers/2018/main_and_glucose_hack/abcdsat_r18.zip 89 | solvers/2018/main_and_glucose_hack/expGlucose.zip 90 | solvers/2018/main_and_glucose_hack/expMC_LRB_VSIDS_Switch.zip 91 | solvers/2018/main_and_glucose_hack/expMC_LRB_VSIDS_Switch_2500.zip 92 | solvers/2018/main_and_glucose_hack/expMC_VSIDS_LRB_Switch_2500.zip 93 | solvers/2018/main_and_glucose_hack/gluHack.zip 94 | solvers/2018/main_and_glucose_hack/glu_mix.zip 95 | solvers/2018/main_and_glucose_hack/glucose-3.0D-patched.zip 96 | solvers/2018/main_and_glucose_hack/glucose-3.0_PADC_10.zip 97 | solvers/2018/main_and_glucose_hack/glucose-3.0_PADC_3.zip 98 | solvers/2018/main_and_glucose_hack/glucose3.0.zip 99 | solvers/2018/main_and_glucose_hack/inIDGlucose.zip 100 | solvers/2018/main_and_glucose_hack/smallsat.zip 101 | solvers/2018/random/CPSparrow.zip 102 | solvers/2018/random/ReasonLS.zip 103 | solvers/2018/random/YalSAT.zip 104 | solvers/2018/random/gluHack.zip 105 | solvers/2018/random/glucose-3.0_PADC_10_NoDRUP.zip 106 | solvers/2018/random/glucose-3.0_PADC_3_NoDRUP.zip 107 | #+end_src 108 | -------------------------------------------------------------------------------- /t/package.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of cl-sat project. 3 | Copyright (c) 2016 Masataro Asai (guicho2.71828@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage :cl-sat.test 8 | (:use :cl 9 | :cl-sat 10 | :fiveam 11 | :trivia :alexandria :iterate)) 12 | (in-package :cl-sat.test) 13 | 14 | (defun s= (a b) 15 | "equivalence between two logical formula" 16 | (match* (a b) 17 | (((list* op1 rest1) 18 | (list* op2 rest2)) 19 | (and (eq op1 op2) 20 | (set-equal rest1 rest2 :test 's=))) 21 | (((symbol) 22 | (symbol)) 23 | (eq a b)))) 24 | 25 | (def-suite :cl-sat) 26 | (in-suite :cl-sat) 27 | 28 | ;; run test with (run! test-name) 29 | 30 | (test symbolicate-form 31 | 32 | (is (s= '(and (or a (not b) c) d) 33 | (symbolicate-form 34 | '(and (or a !b c) d)))) 35 | 36 | (is (s= '(and (or a cl-sat.variables::V1 c) d) 37 | (symbolicate-form 38 | '(and (or a 1 c) d)))) 39 | 40 | (is (s= '(and (or a (not cl-sat.variables::V1) c) d) 41 | (symbolicate-form 42 | '(and (or a -1 c) d)))) 43 | 44 | (signals error (symbolicate-form '!!!!!)) 45 | 46 | (is (s= 'a (symbolicate-form 'a))) 47 | (is (s= '(not a) (symbolicate-form '!a))) 48 | (is (s= 'a (symbolicate-form '!!a))) 49 | (is (s= '(not a) (symbolicate-form '!!!a))) 50 | 51 | ;; https://www.satcompetition.org/2009/format-benchmarks2009.html 52 | ;; 0 is not allowed as a literal 53 | (signals error (symbolicate-form 0))) 54 | 55 | 56 | 57 | (test to-nnf 58 | 59 | (is (s= (to-nnf 60 | '(not (or a b c))) 61 | '(and (not a) (not b) (not c)))) 62 | 63 | (is (s= (to-nnf 64 | '(not (and a b c))) 65 | '(or (not a) (not b) (not c))))) 66 | 67 | 68 | 69 | (test to-cnf-naive 70 | 71 | (is (s= '(and a b c) 72 | (to-cnf-naive '(and a b c)))) 73 | 74 | (is (s= '(or a b c) 75 | (to-cnf-naive '(or a b c)))) 76 | 77 | (is (s= '(and (or a (not b) c) d) 78 | (to-cnf-naive 79 | (to-nnf 80 | (symbolicate-form 81 | '(and (or a !b c) d)))))) 82 | 83 | (is (s= 'a (to-cnf-naive '(and (and (and a)))))) 84 | 85 | 86 | (is (s= '(or (not a) (not b)) 87 | (to-cnf-naive 88 | (to-nnf '(not (and a b)))))) 89 | 90 | (is (s= '(and (not a) (not b)) 91 | (to-cnf-naive 92 | (to-nnf '(not (or a b)))))) 93 | 94 | (is (s= '(and (not a) (not b)) 95 | (to-cnf-naive 96 | (to-nnf '(not (or a b)))))) 97 | 98 | (is (s= '(and (not a) (not b)) 99 | (to-cnf-naive 100 | (to-nnf '(not (or a b)))))) 101 | 102 | (is (s= '(and p (or q a r) (or q b r) s) 103 | (to-cnf-naive 104 | '(and p (or q (and a b) r) s)))) 105 | 106 | (is (s= '(and (or a c) (or b c)) 107 | (to-cnf-naive 108 | '(or (and a b) c)))) 109 | 110 | (is (s= '(and (or a c) (or b c) (or a d) (or b d)) 111 | (to-cnf-naive 112 | '(or (and a b) (and c d))))) 113 | 114 | (is (s= '(and 115 | (or a c e) (or b c e) (or a d e) (or b d e) 116 | (or a c f) (or b c f) (or a d f) (or b d f)) 117 | (to-cnf-naive 118 | '(or (and a b) (and c d) (and e f))))) 119 | 120 | (is (s= '(and 121 | (or a c) (or a d) (or b c) (or b d) 122 | (or e g) (or e h) (or f g) (or f h)) 123 | (to-cnf-naive 124 | '(and 125 | (or (and a b) (and c d)) 126 | (or (and e f) (and g h)))))) 127 | 128 | ;; checking (and) and (or) 129 | 130 | (is (s= '(and a c) 131 | (to-cnf-naive '(and a (or c (and a (or) b)))))) 132 | ;; ^^^^^^^^^^^^^^ == ⊥ 133 | 134 | (is (s= (to-cnf-naive '(and a (or c (and a b)))) 135 | (to-cnf-naive '(and a (or c (and a (and) b)))))) 136 | 137 | (is (s= '(and a (or c a) (or c b)) 138 | (to-cnf-naive '(and a (or c (and a (and) b)))))) 139 | 140 | (is (s= '(and a (or c a) (or c b)) 141 | (to-cnf-naive '(and a (or c (and a (and) b)))))) 142 | 143 | (is (s= '(or) 144 | (to-cnf-naive '(or)))) 145 | (is (s= '(or) 146 | (to-cnf-naive '(and (or))))) 147 | 148 | (is (s= '(and) 149 | (to-cnf-naive '(or (and))))) 150 | (is (s= '(and) 151 | (to-cnf-naive '(and (and)))))) 152 | 153 | #+nil 154 | (test to-cnf-tseytin 155 | ;; trying to test to-cnf-tseytin programatically, but it turns out not trivial 156 | 157 | (let* ((form1 ;; Naive methods convert this form into an exponential CNF 158 | '(or (and a b) (and c d) (and e f) (and g h) (and i j))) 159 | (vars1 '(a b c d e f g h i j)) 160 | (form2 (to-cnf form1)) 161 | (vars2 (remove-duplicates 162 | (set-difference 163 | (flatten form2) 164 | '(and or not)))) 165 | (f (compile nil `(lambda ,vars2 ,form1))) 166 | (g (compile nil `(lambda ,vars2 ,form2)))) 167 | 168 | (iter (repeat 100) 169 | (for args = 170 | (iter (for v in vars2) 171 | (collect (random-elt '(nil t))))) 172 | (is (eq (apply f args) 173 | (apply g args)) 174 | "~@{~a:~a~%~}" 175 | 'form1 form1 176 | 'form2 form2 177 | 'vars1 vars1 178 | 'args args 179 | '(apply f args) (apply f args) 180 | '(apply g args) (apply g args) 181 | )))) 182 | 183 | (test instantiate 184 | (finishes (make-instance 'sat-instance :form '(and a b c))) 185 | (finishes (make-instance 'sat-instance :form '(or a b c))) 186 | (finishes (make-instance 'sat-instance :form '(and (or a !b c) d))) 187 | (finishes (make-instance 'sat-instance :form '(and (and (and a))))) 188 | (finishes (make-instance 'sat-instance :form '(not (and a b)))) 189 | (finishes (make-instance 'sat-instance :form '(not (or a b))))) 190 | 191 | (test print-cnf 192 | (fresh-line) 193 | (finishes (print-cnf (make-instance 'sat-instance :form '(and a b c)))) 194 | (finishes (print-cnf (make-instance 'sat-instance :form '(or a b c)))) 195 | (finishes (print-cnf (make-instance 'sat-instance :form '(and (or a !b c) d)))) 196 | (finishes (print-cnf (make-instance 'sat-instance :form '(and (and (and a)))))) 197 | (finishes (print-cnf (make-instance 'sat-instance :form '(not (and a b))))) 198 | (finishes (print-cnf (make-instance 'sat-instance :form '(not (or a b))))) 199 | (finishes (print-cnf (make-instance 'sat-instance :form '(and a !a))))) 200 | 201 | (test converter 202 | (is (solve '(and a (not a)) :minisat :converter (constantly '(and a))))) 203 | 204 | -------------------------------------------------------------------------------- /t/plaidctf-2015.lisp: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | 7 | (ql:register-local-projects) 8 | (ql:quickload :cl-ppcre) 9 | (ql:quickload :iterate) 10 | (ql:quickload :alexandria) 11 | 12 | (ql:quickload :cl-sat) 13 | (ql:quickload :cl-sat.glucose) 14 | 15 | 16 | (defpackage :plaid 17 | (:use :cl :iterate :alexandria)) 18 | 19 | (in-package :plaid) 20 | 21 | ;; Get this file from 22 | ;; https://raw.githubusercontent.com/ctfs/write-ups-2015/master/plaidctf-2015/reversing/re-gex/regex_57f2cf49f6a354b4e8896c57a4e3c973.txt 23 | 24 | (defvar *path* (asdf:system-relative-pathname :cl-sat "t/regex_57f2cf49f6a354b4e8896c57a4e3c973.txt")) 25 | 26 | (unless (probe-file *path*) 27 | (uiop:run-program 28 | `("curl" 29 | "https://raw.githubusercontent.com/ctfs/write-ups-2015/master/plaidctf-2015/reversing/re-gex/regex_57f2cf49f6a354b4e8896c57a4e3c973.txt") 30 | :output (asdf:system-relative-pathname :cl-sat "t/regex_57f2cf49f6a354b4e8896c57a4e3c973.txt"))) 31 | 32 | (defparameter *regex* (alexandria:read-file-into-string *path*)) 33 | 34 | (defparameter *syntax-tree* (cl-ppcre:parse-string *regex*)) 35 | 36 | 37 | (defconstant +len+ 171) 38 | (defparameter +chars+ "plaidctf") 39 | 40 | 41 | ;; Prepare data structure 42 | (defun sym-for-char (ch i) 43 | (intern (format nil "~a~d" (char-upcase ch) i) 44 | :plaid)) 45 | 46 | (defun syms-for-char (i) 47 | (iter:iter (for ch in-vector +chars+) 48 | (collect (sym-for-char ch i)))) 49 | 50 | (defun syms-for-chars (i chars) 51 | (iter:iter (for ch in chars) 52 | (collect (sym-for-char ch i)))) 53 | 54 | #+(or) 55 | (syms-for-char 10) 56 | 57 | (defun exactly-one-of (syms) 58 | (cons 59 | 'or 60 | (iter:iter (for not-negated in syms) 61 | (for with-1-not-negated = 62 | (mapcar (lambda (i) 63 | (if (eql i not-negated) 64 | i 65 | `(not ,i))) 66 | syms)) 67 | (collect (cons 'and with-1-not-negated))))) 68 | 69 | #+(or) 70 | (exactly-one-of (syms-for-char 10)) 71 | 72 | 73 | 74 | (defun re-clauses-to-sat-vars (pos clauses) 75 | (let ((cls (first clauses))) 76 | (trivia:match cls 77 | ((list* :char-class _) 78 | (cons (syms-for-chars pos (cdr cls)) 79 | (re-clauses-to-sat-vars (1+ pos) 80 | (cdr clauses)))) 81 | (:everything 82 | (re-clauses-to-sat-vars (1+ pos) 83 | (cdr clauses))) 84 | ((list :greedy-repetition from to :everything) 85 | (if (eql from to) 86 | (re-clauses-to-sat-vars (+ pos from) 87 | (cdr clauses))))))) 88 | 89 | 90 | (defun syntax-tree-to-sat-expr-original () 91 | (concatenate 92 | 'list 93 | ;'(and) 94 | (iter:iter (for i below +len+) 95 | (for syms = (syms-for-char i)) 96 | (collect (exactly-one-of syms))) 97 | (iter:iter outer 98 | #+(or) 99 | (repeat 10) 100 | (for desc in (second (third *syntax-tree*))) 101 | (if (and (consp desc) 102 | (eq :sequence (first desc))) 103 | (let ((char-sets (re-clauses-to-sat-vars 0 (rest desc)))) 104 | (collect 105 | (iter:iterate 106 | (with now-positive = ()) 107 | (for negative in char-sets) 108 | (for clause = `(and (not (or ,@ negative)) 109 | ,@ (mapcar 110 | (lambda (chars) 111 | (cons 'or chars)) 112 | now-positive))) 113 | (collect clause into clauses) 114 | (push negative now-positive) 115 | (finally 116 | (return 117 | (cons 'or clauses)))))))))) 118 | 119 | 120 | (defun syntax-tree-to-sat-expr () 121 | (concatenate 122 | 'list 123 | '(and) 124 | (iter:iter (for i below +len+) 125 | (for syms = (syms-for-char i)) 126 | (collect (exactly-one-of syms))) 127 | (iter:iter outer 128 | #+(or) 129 | (repeat 10) 130 | (for desc in (second (third *syntax-tree*))) 131 | (if (and (consp desc) 132 | (eq :sequence (first desc))) 133 | (let* ((char-sets (re-clauses-to-sat-vars 0 (rest desc))) 134 | (this-re-clause 135 | (iter:iterate 136 | (with now-positive = ()) 137 | (for negative in char-sets) 138 | (for clause = `(and ,@ (mapcar 139 | (lambda (clause) 140 | (list 'not clause)) 141 | negative) 142 | ,@ (mapcar 143 | (lambda (chars) 144 | (cons 'or chars)) 145 | now-positive))) 146 | (collect clause into clauses) 147 | (push negative now-positive) 148 | (finally 149 | (return 150 | (if clauses 151 | (cons 'or clauses))))))) 152 | (if this-re-clause 153 | (collect this-re-clause))))))) 154 | 155 | 156 | (defparameter *sat-expression* 157 | (syntax-tree-to-sat-expr)) 158 | 159 | (defparameter *sat-expression-cnf* (time (cl-sat:to-cnf plaid::*sat-expression*))) 160 | 161 | (print :original-number-of-variables) 162 | (print 163 | (length 164 | (set-difference 165 | (remove-duplicates (flatten plaid::*sat-expression*)) 166 | '(or and not)))) 167 | 168 | (print :original+aux-variables) 169 | (print 170 | (length 171 | (set-difference 172 | (remove-duplicates (flatten *sat-expression-cnf*)) 173 | '(or and not)))) 174 | 175 | (print :cnf-clauses) 176 | (print 177 | (length 178 | *sat-expression-cnf*)) 179 | (finish-output) 180 | 181 | #+(or) 182 | (defparameter *cnf* (sat:to-cnf *sat-expression*)) 183 | 184 | #+(or) 185 | (defparameter *result* (sat:solve *sat-expression* 186 | :minisat)) 187 | 188 | #+(or) 189 | (defparameter *result* (sat:solve *sat-expression* 190 | :glucose)) 191 | 192 | (defun main (&rest argv) 193 | (declare (ignorable argv)) 194 | (time (print (sat:solve *sat-expression* :glucose)))) 195 | 196 | 197 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | 2 | * CL-SAT - Common Lisp API to Boolean SAT Solvers 3 | 4 | [[https://travis-ci.org/cl-model-languages/cl-sat][https://travis-ci.org/cl-model-languages/cl-sat.svg?branch=master]] 5 | 6 | This library provides a simple S-exp -> CNF translator and an API to Boolean SAT solvers. 7 | 8 | It does not provide actual implementation to each solver instance by itself. 9 | Currently there are two implementations. Consult the following: 10 | 11 | + https://github.com/guicho271828/cl-sat.minisat 12 | + https://github.com/guicho271828/cl-sat.glucose 13 | 14 | *NEWS* 15 | 16 | + 2018/12/24 :: Implemented Tseytin's transformation for the input logic formula. 17 | The input S-exp can be an arbitrary logical formula that is not necessarily a CNF. 18 | + 2019/1/8 :: Implemented a =:COMPETITION= keyword for the generic function 19 | =SOLVE=, which accepts =:year=, =:track=, =:name= argument 20 | specifying the solver that particupated in SAT Competition 2016,2017,2018. 21 | For example, you can run 22 | =(solve :competition
:name "Lingeling" :track "main_and_glucose_hack" :year 2018)= 23 | to obtain the Lingeling that participated in SAT Competition 2018. 24 | The list of available solvers are: 25 | + 2016: https://baldur.iti.kit.edu/sat-competition-2016/solvers/ 26 | + 2017: https://baldur.iti.kit.edu/sat-competition-2017/solvers/ 27 | + 2017: http://sat2018.forsyte.tuwien.ac.at/solvers/ 28 | + [[./competition.org][Here is the list of solvers that worked.]] 29 | 30 | + 2019/1/25 :: the input formula can now contain (IMPLY lhs rhs) and (IFF lhs rhs). 31 | + 2019/3/6 :: the input formula can contain more operations. See description below 32 | 33 | ** Usage 34 | 35 | In order to load and run minisat2, run follows: 36 | 37 | #+begin_src lisp 38 | (ql:quickload :cl-sat.minisat) 39 | 40 | (cl-sat:solve '(and (or a b) (or a !b c)) :minisat) 41 | -> 42 | (C B) 43 | T 44 | T 45 | 46 | (ql:quickload :cl-sat.glucose) 47 | 48 | (cl-sat:solve '(and (or a b) (or a !b c)) :glucose) 49 | -> 50 | (C B) 51 | T 52 | T 53 | 54 | (cl-sat:solve '(and (or a b) (or a !b c)) :competition :year 2018 :track "main_and_glucose_hack" :name "Lingeling") 55 | -> 56 | (C B A) 57 | T 58 | T 59 | #+end_src 60 | 61 | ** Solver API 62 | 63 | *Generic function* =(solve pathname (eql :solvername) &rest options)= 64 | 65 | Each solver implementation should provide a method =(solve pathname (eql :solvername) &rest options)=. 66 | Additional arguments are passed to the underlying solvers (unless explicitly specified). 67 | 68 | It should return a list of true variables as the first value, a boolean indicating SAT when true, and a 69 | boolean indicating whether the result is determined. For example, 70 | 71 | + =NIL,NIL,NIL= means the solver failed due to the timelimit etc. so the result was indeterminable. 72 | + =NIL,T,T= means that the problem is SAT by assigning all variables to false. 73 | + =NIL,NIL,T= means that the problem is UNSAT. 74 | + On some occasions, depending on the solver, it also returns the fourth value, 75 | which is a list of variables that don't matter: it can be either true 76 | or false. 77 | 78 | ** Input format 79 | 80 | Users will most often use the method specialized to 81 | the S-exp interface =(solve list (eql :solvername) &rest options)=. 82 | 83 | =list= is a cons tree of symbols as an arbitrary propositional formula. 84 | The following logical operators are supported: 85 | 86 | + =or= 87 | + =and= 88 | + =not= 89 | + =imply => when= (synonyms) 90 | + =iff= 91 | + =eq equal <=>= (synonyms, variations of IFF that take multiple statements) 92 | + =xor= 93 | 94 | Each term can be specified by a symbol or a number, but do not mix two styles (it may contain bugs). 95 | Symbols with =!= prefix and negative numbers are interpreted as the negated atoms: =!A= is same as =(not A)=. 96 | 97 | These are internally converted into a NNF via De Morgan's law and then to a CNF via Tseytin transformation. 98 | 99 | Examples: 100 | 101 | #+BEGIN_SRC lisp 102 | a ;; -> equivalent to (and (or a)) 103 | 104 | (or a b) ;; -> equivalent to (and (or a b)) 105 | 106 | (and a b c) ;; -> equivalent to (and (or a) (or b) (or c)) 107 | 108 | (and 1 !b c) ;; -> undefined 109 | 110 | (and a (or !b c)) ;; equivalent to (and (or a) (or (not b) c)) 111 | 112 | (or (and a b) (and b c)) ; -> (and (or aux1 aux2) (or (not aux1) a) (or aux1 (not a) (not b)) ...) 113 | #+END_SRC 114 | 115 | ** S-exp converters 116 | 117 | Users might also be interested in the functions used for processing the logical formula. 118 | 119 | + =(symbolicate-form form)= :: 120 | This function is the first step of converting the input into a normal form. 121 | It normalizes the input tree containing numbers and !-negated vars into a tree of symbols. 122 | Note that it does not guarantee to return any type of normal forms (e.g. NNF,CNF,DNF,ANF). 123 | It accepts any types of compound forms, not limited to AND/OR/NOT. 124 | 125 | + =(expand-extensions form)= :: 126 | Translates extended logical operations into AND, OR, NOT. It support the following operations: 127 | + =IMPLY, =>, WHEN= (synonyms), 128 | + =IFF=, 129 | + =EQ, EQUAL, <=>= (synonyms, a variation of IFF that takes multiple statements), 130 | + =XOR=. 131 | 132 | + =(simplify-nnf form)= :: 133 | Remove some obvious constants / conflicts in the NNF. The result does not contain: 134 | + Single compound forms: 135 | + (and X), (or X) 136 | + Compound forms containing true/false constants: 137 | + =(and ... (or) ... ) -> (or)= 138 | + =(or ... (and) ... ) -> (and)= 139 | + =(or ... X ... (not X) ... ) -> (and)= 140 | + =(and ... X ... (not X) ... ) -> (or)= 141 | + Duplicated forms: 142 | + =(and ... X ... X ... ) -> (and ... X ... ...)= 143 | + =(or ... X ... X ... ) -> (or ... X ... ...)= 144 | 145 | + =(to-nnf form)= :: 146 | Applying De-Morgan's law, the resulting tree contains negations 147 | only at the leaf nodes. Calls =expand-extensions= and =simplify-nnf= internally. 148 | 149 | + =(to-cnf form &optional converter)= :: 150 | Translates the results to a CNF. 151 | Calls =symbolicate-form= and =to-nnf= internally. 152 | =converter= argument specifies which algorithm to use for the conversion, defaulting to =#'to-cnf-tseytin=. 153 | 154 | ** Helper functions 155 | 156 | =(var suffix &optional (prefix "V"))= 157 | 158 | This function interns SUFFIX (usually a number, but can be any printable object) to a symbol with the optional PREFIX. 159 | The new symbol is interned in a package =CL-SAT.VARIABLES= . 160 | 161 | This function is particularly useful for implementing some SAT encoding of other 162 | problems, such as knapsack or bin-packing problem. 163 | 164 | ** Dependencies 165 | 166 | Required libraries depends on the solver instance. See the corresponding documentation. 167 | 168 | This library is at least tested on implementation listed below: 169 | 170 | + SBCL 1.3.5 on X86-64 Linux 3.19.0-59-generic (author's environment) 171 | 172 | Also, it depends on the following libraries: 173 | 174 | + trivia by Masataro Asai :: 175 | NON-optimized pattern matcher compatible with OPTIMA, with extensible optimizer interface and clean codebase 176 | 177 | + alexandria by :: 178 | Alexandria is a collection of portable public domain utilities. 179 | 180 | + iterate by :: 181 | Jonathan Amsterdam's iterator/gatherer/accumulator facility 182 | 183 | ** Author 184 | 185 | + Masataro Asai (guicho2.71828@gmail.com) 186 | 187 | * Copyright 188 | 189 | Copyright (c) 2016 Masataro Asai (guicho2.71828@gmail.com) 190 | 191 | 192 | * License 193 | 194 | Licensed under the LLGPL License. 195 | 196 | 197 | 198 | -------------------------------------------------------------------------------- /src/3-dimacs.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-sat) 2 | ;; http://people.sc.fsu.edu/~jburkardt/data/cnf/cnf.html 3 | ;; ( x(1) OR ( NOT x(3) ) ) 4 | ;; AND 5 | ;; ( x(2) OR x(3) OR ( NOT x(1) ) ). 6 | 7 | ;; c simple_v3_c2.cnf <<< comments 8 | ;; c 9 | ;; p cnf 3 2 <<< problem spec, cnf type, #vars, #clauses 10 | ;; 1 -3 0 11 | ;; 2 3 -1 0 12 | 13 | 14 | (defvar *verbosity* 0) 15 | (declaim (type (integer 0 3) *verbosity*)) 16 | 17 | (defun print-cnf (instance &optional (stream *standard-output*) (*verbosity* *verbosity*)) 18 | (ematch instance 19 | ((sat-instance cnf variables) 20 | (when (<= 1 *verbosity*) 21 | (pprint-logical-block (stream nil :per-line-prefix "c ") 22 | (when (<= 2 *verbosity*) 23 | (format stream "~&~a" cnf)) 24 | (iter (for i from 1) 25 | (for v in-vector variables) 26 | (format stream "~&Variable ~a : ~a" i v)))) 27 | 28 | (match cnf 29 | ((or (list* 'and clauses) 30 | (<> clauses (list cnf))) 31 | (format stream "~&p cnf ~A ~A" (length variables) (length clauses)) 32 | 33 | (iter (for c in clauses) 34 | (ematch c 35 | ((or (list* 'or terms) 36 | (<> terms (list c))) 37 | (when (<= 3 *verbosity*) 38 | (format stream "~&c ~a" c)) 39 | (format stream "~&~{~a ~}0" 40 | (iter (for term in terms) 41 | (collect 42 | (ematch term 43 | ((list 'not atom) 44 | (- (1+ (position atom variables)))) 45 | (atom 46 | (1+ (position atom variables)))))))))) 47 | (fresh-line stream)))))) 48 | 49 | 50 | 51 | ;; https://www.satcompetition.org/2004/format-solvers2004.html 52 | 53 | ;; Output Format 54 | ;; We ask for the solvers to DISPLAY messages on the standard output that will be used to check the results and to RETURN EXIT CODE to be handled by the SAT-Ex system. The output format is partly inspired by the previously defined DIMACS output specification and may be used to manually check some results. 55 | ;; Messages 56 | ;; There is no specific order in the solvers output lines. However, all line, according to its first char, must belong to one of the three following categories: 57 | ;; 58 | ;; comments (any information that authors want to emphasize, such like #backtracks, #flips,... or internal cpu-time), beginning with the two chars "c " 59 | ;; solution (satisfiable or not). Only one line of this type is allowed. This line must begin with the two chars " s " and must be one of the following ones: 60 | ;; s SATISFIABLE 61 | ;; s UNSATISFIABLE 62 | ;; s UNKNOWN 63 | ;; values of a solution (if any), beginning with the two chars "v " (to be precised in the following). 64 | ;; 65 | ;; When a solver answers UNKNOWN, it is charged with the maximum allowed time SATTIMEOUT. 66 | ;; 67 | ;; Technically, the two first chars are important and must be strictly respected: scripts will use traditional grep commands to parse results (and at least to partition standard output). 68 | ;; 69 | ;; If the solver does not display a solution line (or if the solution line is not valid), then UNKNOWN will be assumed. 70 | ;; Providing a model 71 | ;; If the solver outputs SATISFIABLE, it should provide a model (or an implicant) of the instance that will be used to check the correctness of the answer. I.e., it must provide a 0-terminated sequence of distinct non-contradictory literals that makes every clause of the input formula true. It is NOT necessary to list the literals corresponding to all variables if a smaller amount of literals suffices. The order of the literals does not matter. Arbitrary white space characters, including ordinary white spaces, newline and tabulation characters, are allowed between the literals, as long as each line containing the literals is a values line, i.e. it begins with the two chars "v ". 72 | ;; 73 | ;; If the solver cannot provide such a certificate for satisfiable instances, then the author(s) are asked to contact Laurent Simon directly; then the decision concerning the solver will be made (e.g., running the solver hors concours). 74 | ;; 75 | ;; Note that we do not require a proof for unsatisfiability. The values lines should only appear with SATISFIABLE instance. 76 | ;; 77 | ;; For instance, the following outputs are valid for the instances given in example: 78 | ;; 79 | ;; mycomputer:~$ ./mysolver myinstance-sat 80 | ;; c mysolver 6.55957 starting with SATTIMEOUT fixed to 1000s 81 | ;; c Trying to guess a solution... 82 | ;; s SATISFIABLE 83 | ;; v -3 4 84 | ;; v -6 18 21 85 | ;; v 1 -7 0 86 | ;; c Done (mycputime is 234s). 87 | 88 | (defun parse-dimacs-output (file instance) 89 | (iter (for line in-file file using #'read-line) 90 | 91 | (with sure = nil) 92 | (with satisfiable = nil) 93 | (with assignments = (make-array (length (variables instance)) 94 | :element-type '(integer 0 2) 95 | :initial-element 2)) 96 | 97 | (match line 98 | ((string* #\c _) 99 | ;; do nothing 100 | ) 101 | ((string* #\v _) 102 | (with-input-from-string (s (subseq line 2)) 103 | (iter (for v in-stream s) 104 | (until (zerop v)) 105 | (setf (aref assignments (1- (abs v))) 106 | (if (plusp v) 1 0))))) 107 | ("s SATISFIABLE" 108 | (setf sure t satisfiable t)) 109 | ("s UNSATISFIABLE" 110 | (setf sure t satisfiable nil)) 111 | ("s UNKNOWN" 112 | (setf sure nil satisfiable nil)) 113 | (_ 114 | (simple-style-warning "found a garbage line in the output: ~a" line))) 115 | 116 | (finally 117 | (iter (for a in-vector assignments with-index i) 118 | (for v = (aref (variables instance) i)) 119 | (case a 120 | (1 (when (not (eq (find-package :cl-sat.aux-variables) 121 | (symbol-package v))) 122 | (collect v into trues))) 123 | (2 (when (not (eq (find-package :cl-sat.aux-variables) 124 | (symbol-package v))) 125 | (collect v into dont-care)))) 126 | (finally 127 | (return-from parse-dimacs-output 128 | (values trues satisfiable sure dont-care))))))) 129 | 130 | 131 | ;; https://dwheeler.com/essays/minisat-user-guide.html 132 | ;; SAT 133 | ;; 1 2 -3 4 5 0 134 | 135 | ;; Or just assignments, e.g., in glucose 136 | ;; 1 2 -3 4 5 0 137 | 138 | (defun parse-assignments (file instance &optional ignore-first) 139 | "Parser for Minisat 2.2" 140 | (let ((assignments (make-array (length (variables instance)) 141 | :element-type '(integer 0 2) 142 | :initial-element 2))) 143 | (iter 144 | (for v in-file file) 145 | (when (and ignore-first (first-iteration-p)) 146 | (check-type v symbol) 147 | (assert (string= "SAT" v)) 148 | (next-iteration)) 149 | (when (= v 0) 150 | (leave)) 151 | (setf (aref assignments (1- (abs v))) 152 | (if (plusp v) 1 0))) 153 | (iter 154 | (for a in-vector assignments with-index i) 155 | (for v = (aref (variables instance) i)) 156 | (case a 157 | (1 (when (not (eq (find-package :cl-sat.aux-variables) 158 | (symbol-package v))) 159 | (collect v into trues))) 160 | (2 (when (not (eq (find-package :cl-sat.aux-variables) 161 | (symbol-package v))) 162 | (collect v into dont-care)))) 163 | (finally 164 | (return 165 | (values trues t t dont-care)))))) 166 | 167 | 168 | 169 | ;; todo: RUP proof in SAT competition 2009 https://www.satcompetition.org/2009/ 170 | -------------------------------------------------------------------------------- /t/competitions.lisp: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | (in-package :cl-sat.test) 6 | 7 | (defun runner (year track name) 8 | (cl-sat:solve '(and (or a b) (or a !b c)) :competition 9 | :year year :track track :name name)) 10 | 11 | 12 | (defparameter *configs* 13 | '((2016 "agile" "CHBR_glucose_agile") 14 | (2016 "agile" "CHBR_glucose_tuned_agile") 15 | (2016 "agile" "COMiniSatPSChandrasekharnoDRUP") 16 | (2016 "agile" "GHackCOMSPS_no_DRUP") 17 | (2016 "agile" "Lingeling") 18 | (2016 "agile" "Lingelingbbcnotrace") 19 | (2016 "agile" "MapleCMS") 20 | (2016 "agile" "MapleCOMSPS_CHB_no_DRUP") 21 | (2016 "agile" "MapleCOMSPS_LRB_no_DRUP") 22 | (2016 "agile" "MapleCOMSPS_no_DRUP") 23 | (2016 "agile" "MapleGlucose") 24 | ;; (2016 "agile" "Riss6") 25 | (2016 "agile" "Splatz06vnotrace") 26 | (2016 "agile" "YalSAT03r") 27 | (2016 "agile" "abcdSAT_drup") 28 | (2016 "agile" "cmsat5_agile2") 29 | (2016 "agile" "glucosePLE") 30 | (2016 "agile" "glucose_hack_kiel_newScript") 31 | (2016 "agile" "glue_alt") 32 | (2016 "agile" "glueminisat-2.2.10-81-agile") 33 | (2016 "agile" "gulch-agile") 34 | (2016 "agile" "gulch-once") 35 | (2016 "agile" "tb_glucose_agile") 36 | (2016 "agile" "tc_glucose_agile") 37 | (2016 "main" "BeansAndEggs") 38 | (2016 "main" "CHBR_glucose") 39 | (2016 "main" "CHBR_glucose_tuned") 40 | (2016 "main" "COMiniSatPSChandrasekharDRUP") 41 | (2016 "main" "GHackCOMSPS_DRUP") 42 | (2016 "main" "Glucose_nbSat") 43 | (2016 "main" "Lingelingbbcmain") 44 | (2016 "main" "MapleCMS") 45 | (2016 "main" "MapleCOMSPS_CHB_DRUP") 46 | (2016 "main" "MapleCOMSPS_DRUP") 47 | (2016 "main" "MapleCOMSPS_LRB_DRUP") 48 | (2016 "main" "MapleGlucose") 49 | ;; (2016 "main" "Riss6") 50 | (2016 "main" "Scavel_SAT") 51 | (2016 "main" "Splatz06vmain") 52 | (2016 "main" "YalSAT03r") 53 | (2016 "main" "abcdSAT_drup") 54 | (2016 "main" "cmsat5_autotune2") 55 | (2016 "main" "cmsat5_main2") 56 | (2016 "main" "drat-trim") 57 | (2016 "main" "glucose") 58 | (2016 "main" "glucosePLE") 59 | (2016 "main" "glucose_hack_kiel_newScript") 60 | (2016 "main" "glue_alt") 61 | (2016 "main" "glueminisat-2.2.10-81-main") 62 | (2016 "main" "gulch") 63 | (2016 "main" "tb_glucose") 64 | (2016 "main" "tc_glucose") 65 | ;; (2016 "parallel16" "ParaGlueminisat_2016") 66 | ;; (2016 "parallel16" "Priss6") 67 | ;; (2016 "parallel16" "ampharos-sat-2016") 68 | ;; (2016 "parallel16" "cbpenelope2016") 69 | ;; (2016 "parallel16" "ccspenelope2016") 70 | ;; (2016 "parallel16" "cmsat5_run_parallel") 71 | ;; (2016 "parallel16" "dissolve-SATcomp16.tar.gz") 72 | ;; (2016 "parallel16" "gluco_par") 73 | ;; (2016 "parallel16" "penelope_for_2015_AICR_24_Pair_BUMP100") 74 | ;; (2016 "parallel16" "penelope_for_2015_AICR_48_Pair_BUMP100") 75 | ;; (2016 "parallel16" "plingeling-bbc-sc2016") 76 | ;; (2016 "parallel16" "syrup") 77 | ;; (2016 "parallel16" "tbParaGlueminisat_2016") 78 | ;; (2016 "parallel16" "treengeling-bbc-sc2016") 79 | (2016 "random" "CSCCSat") 80 | (2016 "random" "DCCAlm") 81 | (2016 "random" "YalSAT03r") 82 | (2016 "random" "cmsat5_agile") 83 | (2016 "random" "dimetheus") 84 | (2016 "random" "multi-sat") 85 | (2016 "random" "polypower1.0") 86 | (2016 "random" "polypower2.0") 87 | (2016 "random" "stocBCD") 88 | 89 | 90 | ;; zip is too large; dont want to test 91 | ;; (2017 "agile" "Candy") 92 | ;; (2017 "agile" "Riss7") 93 | (2017 "agile" "abcdsat_a17") 94 | (2017 "agile" "abcdsat_r17") 95 | (2017 "agile" "bs_glucose") 96 | (2017 "agile" "cadical-sc17-agile") 97 | (2017 "agile" "cadical-sc17-noproof") 98 | (2017 "agile" "glu_vc") 99 | (2017 "agile" "glucose-4.1") 100 | (2017 "agile" "glulu") 101 | (2017 "agile" "lingeling-bbe") 102 | (2017 "agile" "tch_glucose1") 103 | (2017 "agile" "tch_glucose2") 104 | (2017 "agile" "tch_glucose3") 105 | (2017 "agile" "yalsat-03s") 106 | ;; (2017 "incremental" "abcdsat_i17") 107 | ;; (2017 "incremental" "candy-incremental.tar.gz") 108 | ;; (2017 "incremental" "glucose-ipasir") 109 | ;; (2017 "incremental" "riss_7-ipasir.tar.gz") 110 | (2017 "main" "COMiniSatPS_Pulsar_drup") 111 | ;; zip is too large; dont want to test 112 | ;; (2017 "main" "Candy") 113 | ;; (2017 "main" "CandyRSILi") 114 | ;; (2017 "main" "CandyRSILv") 115 | ;; (2017 "main" "CandySL21") 116 | (2017 "main" "GHackCOMSPS_drup") 117 | (2017 "main" "MapleCOMSPS_CHB_VSIDS_drup") 118 | (2017 "main" "MapleCOMSPS_LRB_VSIDS_2_drup") 119 | (2017 "main" "MapleCOMSPS_LRB_VSIDS_drup") 120 | (2017 "main" "MapleLRB_LCM") 121 | (2017 "main" "MapleLRB_LCMoccRestart") 122 | (2017 "main" "Maple_LCM") 123 | (2017 "main" "Maple_LCM_Dist") 124 | ;; (2017 "main" "Riss7") 125 | (2017 "main" "abcdsat_r17") 126 | (2017 "main" "bs_glucose") 127 | (2017 "main" "cadical-sc17-agile-proof") 128 | (2017 "main" "cadical-sc17-proof") 129 | (2017 "main" "glu_vc") 130 | (2017 "main" "glucose-3.0+width") 131 | (2017 "main" "glucose-4.1") 132 | (2017 "main" "lingeling-bbe") 133 | (2017 "main" "satUZK-seq") 134 | (2017 "main" "tch_glucose1") 135 | (2017 "main" "tch_glucose2") 136 | (2017 "main" "tch_glucose3") 137 | ;; (2017 "nolimits" "COMiniSatPS_Pulsar_no_drup") 138 | ;; (2017 "nolimits" "GHackCOMSPS_no_drup") 139 | ;; (2017 "nolimits" "MapleCOMSPS_CHB_VSIDS_no_drup") 140 | ;; (2017 "nolimits" "MapleCOMSPS_LRB_VSIDS_2_no_drup") 141 | ;; (2017 "nolimits" "MapleCOMSPS_LRB_VSIDS_no_drup") 142 | ;; (2017 "nolimits" "Riss7") 143 | ;; (2017 "nolimits" "Sat4jdefault") 144 | ;; (2017 "nolimits" "abcdSAT_n17") 145 | ;; (2017 "nolimits" "abcdsat_r17") 146 | ;; (2017 "nolimits" "cadical-sc17-agile") 147 | ;; (2017 "nolimits" "cadical-sc17-noproof") 148 | ;; (2017 "nolimits" "glu_vc") 149 | ;; (2017 "nolimits" "glulu") 150 | ;; (2017 "nolimits" "lingeling-bbe") 151 | ;; (2017 "parallel" "abcdsat_parallel") 152 | ;; (2017 "parallel" "cbpenelope2017") 153 | ;; (2017 "parallel" "ccspenelope2017") 154 | ;; (2017 "parallel" "ddc-submit.tar.gz") 155 | ;; (2017 "parallel" "painless") 156 | ;; (2017 "parallel" "plingeling-bbe-sc2017") 157 | ;; (2017 "parallel" "scalope") 158 | ;; (2017 "parallel" "syrup") 159 | ;; (2017 "parallel" "treengeling-bbe-sc2017") 160 | (2017 "random" "Score2SAT") 161 | (2017 "random" "tch_glucose3") 162 | (2017 "random" "yalsat-03s") 163 | 164 | 165 | (2018 "main_and_glucose_hack" "COMiniSatPS_Pulsar_drup") 166 | (2018 "main_and_glucose_hack" "CaDiCaL") 167 | ;; zip is too large; dont want to test 168 | ;; (2018 "main_and_glucose_hack" "Candy") 169 | (2018 "main_and_glucose_hack" "GHackCOMSPS_drup") 170 | (2018 "main_and_glucose_hack" "Glucose_Hack_Kiel_fastBVE") 171 | (2018 "main_and_glucose_hack" "Lingeling") 172 | (2018 "main_and_glucose_hack" "MapleCOMSPS_CHB_VSIDS_drup") 173 | (2018 "main_and_glucose_hack" "MapleCOMSPS_LRB_VSIDS_2_drup") 174 | (2018 "main_and_glucose_hack" "MapleCOMSPS_LRB_VSIDS_drup") 175 | (2018 "main_and_glucose_hack" "MapleLCMDistChronoBT") 176 | (2018 "main_and_glucose_hack" "Maple_CM") 177 | (2018 "main_and_glucose_hack" "Maple_CM_Dist") 178 | (2018 "main_and_glucose_hack" "Maple_CM_ordUIP+") 179 | (2018 "main_and_glucose_hack" "Maple_CM_ordUIP") 180 | (2018 "main_and_glucose_hack" "Maple_LCM+BCrestart") 181 | (2018 "main_and_glucose_hack" "Maple_LCM+BCrestart_M1") 182 | (2018 "main_and_glucose_hack" "Maple_LCM_M1") 183 | (2018 "main_and_glucose_hack" "Maple_LCM_Scavel") 184 | (2018 "main_and_glucose_hack" "Maple_LCM_Scavel_200") 185 | (2018 "main_and_glucose_hack" "Minisat-v2.2.0-106-ge2dd095") 186 | ;; (2018 "main_and_glucose_hack" "Riss7.1") 187 | ;; (2018 "main_and_glucose_hack" "Sparrow2Riss-2018") 188 | (2018 "main_and_glucose_hack" "YalSAT") 189 | (2018 "main_and_glucose_hack" "abcdsat_r18") 190 | (2018 "main_and_glucose_hack" "cms55-main-all4fixed") 191 | (2018 "main_and_glucose_hack" "expGlucose") 192 | (2018 "main_and_glucose_hack" "expMC_LRB_VSIDS_Switch") 193 | (2018 "main_and_glucose_hack" "expMC_LRB_VSIDS_Switch_2500") 194 | (2018 "main_and_glucose_hack" "expMC_VSIDS_LRB_Switch_2500") 195 | (2018 "main_and_glucose_hack" "gluHack") 196 | (2018 "main_and_glucose_hack" "glu_mix") 197 | (2018 "main_and_glucose_hack" "glucose-3.0D-patched") 198 | (2018 "main_and_glucose_hack" "glucose-3.0_PADC_3") 199 | (2018 "main_and_glucose_hack" "glucose-3.0_PADC_10") 200 | (2018 "main_and_glucose_hack" "glucose3.0") 201 | (2018 "main_and_glucose_hack" "glucose4.2.1") 202 | (2018 "main_and_glucose_hack" "inIDGlucose") 203 | (2018 "main_and_glucose_hack" "smallsat") 204 | ;; zip is too large; dont want to test 205 | ;; (2018 "main_and_glucose_hack" "varisat") 206 | 207 | (2018 "random" "CPSparrow") 208 | (2018 "random" "ReasonLS") 209 | ;; (2018 "random" "Sparrow2Riss-2018") 210 | (2018 "random" "YalSAT") 211 | (2018 "random" "dimetheus") 212 | (2018 "random" "expGlucoseSilent") 213 | (2018 "random" "gluHack") 214 | (2018 "random" "glucose-3.0_PADC_3_NoDRUP") 215 | (2018 "random" "glucose-3.0_PADC_10_NoDRUP") 216 | ;; it does not finish 217 | ;; (2018 "random" "lawa") 218 | (2018 "random" "probSAT"))) 219 | 220 | 221 | (test competition 222 | (iter (for config in *configs*) 223 | (ignore-errors 224 | (finishes (apply #'runner config))))) 225 | -------------------------------------------------------------------------------- /src/1-parse.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | Parses a s-exp and turn it into a logical form that is compatible to SAT solvers 4 | 5 | Notes: 6 | 7 | NNF: Negation Normal Form. a tree of ANDs and ORs ending with either positive / negative literals. There are no NOTs applied to ANDs and ORs 8 | 9 | CNF: Conjunctive Normal Form. ANDs of ORs of positive / negative literals. Also known as "product of sums" forms. 10 | 11 | DNF: Disjunctive Normal Form. (Not Duke Nukem Forever) ORs of ANDs of positive / negative literals. 12 | 13 | ANF: Algebraic Normal Form. XORs of ANDs of positive literals. No NOTs. This form is canonical -- there is only one form up to permutations. 14 | 15 | 16 | 17 | We first convert a form into a SYMBOLIC FORM: 18 | 19 | + convert every numbers into a symbol in CL-SAT.VARIABLES PACKAGE, 20 | + convert every negative numbers into (NOT VAR) form, 21 | + convert every !-negated symbols into (NOT VAR) form. 22 | 23 | We next convert it into an NNF, and finally convert it into a CNF. 24 | 25 | |# 26 | 27 | (in-package :cl-sat) 28 | ;; allow both (not symbol) and !symbol 29 | ;; allow numbers (as in cnf) 30 | 31 | (defpackage cl-sat.variables) 32 | (defpackage cl-sat.aux-variables) 33 | 34 | (defun var (suffix &optional (prefix "V")) 35 | "Helper function: Interns SUFFIX (usually a number, but can be any printable object) to a symbol with the optional PREFIX. 36 | The new symbol is interned in package CL-SAT.VARIABLES." 37 | (intern (format nil "~a~a" prefix suffix) :cl-sat.variables)) 38 | 39 | (defun aux (suffix &optional (prefix "A")) 40 | "intern a suffix to an auxiliary symbol" 41 | (intern (format nil "~a~a" prefix suffix) :cl-sat.aux-variables)) 42 | 43 | 44 | (defun symbolicate-form (tree) 45 | " 46 | This function is the first step of converting the input into a normal form. 47 | It normalizes the input tree containing numbers and !-negated vars into a tree of symbols. 48 | Note that it does not guarantee to return any type of normal forms (e.g. NNF,CNF,DNF,ANF). 49 | It accepts any types of compound forms, not limited to AND/OR/NOT. 50 | " 51 | (ematch tree 52 | ((symbol name) 53 | (let ((pos (position-if (lambda (c) (char/= c #\!)) name))) 54 | (cond 55 | ((null pos) 56 | ;; all characters are !, 57 | (error "Found an invalid symbol ~a whose name consists of ! only." tree)) 58 | ((evenp pos) 59 | ;; positive literal. !s in the middle of the names are not considered 60 | ;; here, we consider only those at the beginning of literal name. 61 | (intern (subseq name pos) (symbol-package tree))) 62 | (t 63 | `(not ,(intern (subseq name pos) (symbol-package tree))))))) 64 | ((< 0) 65 | `(not ,(var (- tree)))) 66 | ((> 0) 67 | (var tree)) 68 | ((= 0) 69 | ;; https://www.satcompetition.org/2009/format-benchmarks2009.html 70 | ;; 0 is not allowed as a literal 71 | (signal 'type-error :expected-type '(or symbol cons (and integer (not (eql 0)))) tree)) 72 | ((list* head rest) 73 | (list* head (mapcar #'symbolicate-form rest))))) 74 | 75 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 76 | ;; NNF 77 | 78 | (defun negate (form) 79 | "Simple negation not involving De-Morgan's law." 80 | (ematch form 81 | ((list 'not form) 82 | form) 83 | (_ 84 | `(not ,form)))) 85 | 86 | (defun to-nnf (form) 87 | "Applying De-Morgan's law, the resulting tree contains negations 88 | only at the leaf nodes. Calls expand-extensions internally." 89 | (simplify-nnf (%to-nnf (expand-extensions form)))) 90 | 91 | (defun expand-extensions (form) 92 | "Translates extended logical operations into AND, OR, NOT. 93 | IMPLY, =>, WHEN (synonyms), 94 | IFF, 95 | EQ, EQUAL, <=> (synonyms, a variation of IFF that takes multiple statements), 96 | XOR. 97 | " 98 | (ematch form 99 | ;; FIXME: EQ and XOR does not seem to have the identity and zero 100 | ;; but correct me 101 | ((list (and op (or 'imply '=> 'when 'iff 'eq 'equal '<=> 'xor))) 102 | (error "malformed ~a form: ~a, takes 2 arguments" op form)) 103 | ((list (and op (or 'imply '=> 'when 'iff 'eq 'equal '<=> 'xor)) _) 104 | (error "malformed ~a form: ~a, takes 2 arguments" op form)) 105 | 106 | ((list (or 'imply '=> 'when) lhs rhs) 107 | (let ((lhs (expand-extensions lhs)) 108 | (rhs (expand-extensions rhs))) 109 | `(or (not ,lhs) ,rhs))) 110 | 111 | ((list 'iff lhs rhs) 112 | (let ((lhs (expand-extensions lhs)) 113 | (rhs (expand-extensions rhs))) 114 | `(and (or (not ,lhs) ,rhs) 115 | (or (not ,rhs) ,lhs)))) 116 | 117 | ((list* (or 'eq 'equal '<=>) rest) 118 | `(and 119 | ,@(iter outer 120 | (for (e1 . rest2) on rest) 121 | (iter (for e2 in rest2) 122 | (in outer 123 | (collect (expand-extensions `(iff ,e1 ,e2)))))))) 124 | 125 | ((list* 'xor first rest) 126 | `(not ,(expand-extensions `(iff ,first (xor ,@rest))))) 127 | 128 | ((list* 'and rest) `(and ,@(mapcar #'expand-extensions rest))) 129 | ((list* 'or rest) `(or ,@(mapcar #'expand-extensions rest))) 130 | ((list* 'not rest) `(not ,@(mapcar #'expand-extensions rest))) 131 | ((symbol) 132 | form))) 133 | 134 | (defun %to-nnf (form) 135 | (ematch form 136 | ((list* 'and rest) `(and ,@(mapcar #'%to-nnf rest))) 137 | ((list* 'or rest) `(or ,@(mapcar #'%to-nnf rest))) 138 | ;; negated 139 | ((list 'not (list* 'or rest)) 140 | ;; De-Morgan's law 141 | `(and ,@(mapcar (compose #'%to-nnf #'negate) rest))) 142 | ((list 'not (list* 'and rest)) 143 | ;; De-Morgan's law 144 | `(or ,@(mapcar (compose #'%to-nnf #'negate) rest))) 145 | ((list 'not (list 'not further)) 146 | (%to-nnf further)) 147 | ((list 'not (symbol)) 148 | form) 149 | ((symbol) 150 | form))) 151 | 152 | (defun %merge-same-clauses (type forms) 153 | (iter (for elem in forms) 154 | (match elem 155 | ((list* (eq type) subrest) 156 | (appending subrest)) 157 | (_ 158 | (collecting elem))))) 159 | 160 | (defun symbol< (a b) 161 | (match* (a b) 162 | (((symbol :package p1) (symbol :package p2)) 163 | (cond 164 | ((and (not p1) (not p2)) 165 | (string< a b)) 166 | ((and (not p1) p2) 167 | t) 168 | ((and p1 (not p2)) 169 | nil) 170 | ((and p1 p2) 171 | (if (eq p1 p2) 172 | (string< a b) 173 | (string< (package-name p1) (package-name p2)))))))) 174 | 175 | (defun symbol<= (a b) 176 | (or (eq a b) 177 | (symbol< a b))) 178 | 179 | (defun clause< (a b) 180 | (match* (a b) 181 | (((symbol) (symbol)) 182 | (symbol< a b)) 183 | (((symbol) (type list)) 184 | t) 185 | (((type list) (symbol)) 186 | nil) 187 | (((list* f1 r1) (list* f2 r2)) 188 | (or (clause< f1 f2) 189 | (and (equal f1 f2) 190 | (some #'clause< r1 r2)))))) 191 | 192 | (defun %sort-clauses (forms) 193 | (sort (copy-list forms) 194 | #'clause<)) 195 | 196 | (defun simplify-nnf (form) 197 | "Remove some obvious constants / conflicts in the form. The result does not contain: 198 | Single compound forms: 199 | (and X), (or X) 200 | Compound forms containing true/false constants: 201 | (and ... (or) ... ) -> (or) 202 | (or ... (and) ... ) -> (and) 203 | (or ... X ... (not X) ... ) -> (and) 204 | (and ... X ... (not X) ... ) -> (or) 205 | Duplicated forms: 206 | (and ... X ... X ... ) -> (and ... X ... ...) 207 | (or ... X ... X ... ) -> (or ... X ... ...) 208 | " 209 | (ematch form 210 | ((list 'and) form) 211 | ((list 'or) form) 212 | ((list 'and x) (simplify-nnf x)) 213 | ((list 'or x) (simplify-nnf x)) 214 | ((list* 'and rest) 215 | (let* ((rest (mapcar #'simplify-nnf rest)) 216 | (rest (%merge-same-clauses 'and rest)) ; (and) is eliminated here 217 | (rest (%sort-clauses rest))) 218 | (cond 219 | ((member '(or) rest :test 'equal) 220 | '(or)) 221 | ((iter outer 222 | (for (c1 . rest2) on rest) 223 | (iter (for c2 in rest2) 224 | (in outer 225 | (thereis 226 | (match c2 227 | ((list 'not (equal c1)) t)))))) 228 | '(or)) 229 | (t 230 | (match (remove-duplicates rest :test 'equal) 231 | ((list x) x) 232 | (nil 233 | ;; happens when rest = '((and) (and)) is reduced by %merge-same-clauses 234 | `(and)) 235 | (result 236 | (list* 'and result))))))) 237 | ((list* 'or rest) 238 | (let* ((rest (mapcar #'simplify-nnf rest)) 239 | (rest (%merge-same-clauses 'or rest)) ;(or) is eliminated here 240 | (rest (%sort-clauses rest))) 241 | (cond 242 | ((member '(and) rest :test 'equal) 243 | '(and)) 244 | ((iter outer 245 | (for (c1 . rest2) on rest) 246 | (iter (for c2 in rest2) 247 | (in outer 248 | (thereis 249 | (match c2 250 | ((list 'not (equal c1)) t)))))) 251 | ;; (or ... A ... (not A) ...) 252 | '(and)) 253 | (t 254 | (match (remove-duplicates rest :test 'equal) 255 | ((list x) x) 256 | (nil 257 | ;; happens when rest = '((or) (or)) is reduced by %merge-same-clauses 258 | `(or)) 259 | (result 260 | (list* 'or result))))))) 261 | ;; non-nnf is rejected here 262 | ((list 'not (symbol)) 263 | form) 264 | ((symbol) 265 | form))) 266 | 267 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 268 | ;; ANF (wip) 269 | 270 | (defun to-anf (form) 271 | "Convert an arbitrary logical form into an algebraic normal form consisting of XOR, AND, and T." 272 | (%to-anf (expand-extensions form))) 273 | 274 | (defun %to-anf (form) 275 | (flet ((%xor (forms) 276 | ;; eliminate when there are even number of appearances 277 | (iter (for form in (%merge-same-clauses 'xor forms)) 278 | (with acc = nil) 279 | (if (member form acc :test 'equal) 280 | (setf acc (delete form acc :test 'equal)) 281 | (push form acc)) 282 | (finally 283 | (return 284 | (match acc 285 | ((list x) x) 286 | (_ `(xor ,@(%sort-clauses acc))))))))) 287 | (ematch form 288 | ((symbol) form) 289 | ((list 'and) t) 290 | ((list 'or) `(xor t t)) 291 | ((list 'and x) (%to-anf x)) 292 | ((list 'or x) (%to-anf x)) 293 | 294 | ((list 'not x) 295 | (%xor (list t (%to-anf x)))) 296 | 297 | ((list* 'or x rest) 298 | (%xor (list (%to-anf x) 299 | (%to-anf `(or ,@rest)) 300 | (%to-anf `(and ,x (or ,@rest)))))) 301 | 302 | ((list* 'and rest) 303 | (let* ((elems (%merge-same-clauses 'and (mapcar #'%to-anf rest))) 304 | xors others) 305 | (iter (for elem in elems) 306 | (match elem 307 | ((list* 'xor args) 308 | (push args xors)) 309 | (_ 310 | (push elem others)))) 311 | (if xors 312 | (%xor (apply #'alexandria:map-product 313 | (lambda (&rest args) `(and ,@(append args others))) 314 | xors)) 315 | `(and ,@others))))))) 316 | 317 | ;; (cl-sat:to-anf '(or a b (and c (and d (not e)) (and f (or g h))))) 318 | ;; (cl-sat:to-anf '(or a b)) 319 | ;; (cl-sat:to-anf '(or (not (not b)) a)) 320 | 321 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 322 | ;; Naive CNF 323 | 324 | (defun dispatch (form top k) 325 | "Naive implementation that expands the inner ANDs of ORs into ORs of ANDs (potentially exponentially explode). 326 | Implemented using Continuation Passing Style. Calling K with a value is equivalent to returning the result of processing FORM. 327 | 328 | TOP is a boolean which, when NIL, means the current position is inside an OR." 329 | 330 | (ematch* (form top) 331 | ;; length 0 332 | 333 | (((list _) _) 334 | ;; always satisfiable (and) or unsatisfiable (or). 335 | ;; return the form as it is. 336 | (funcall k form)) 337 | 338 | ;; length 1 339 | (((list 'not _) _) 340 | (funcall k form)) 341 | 342 | (((list _ first) _) 343 | ;; (and x) is equivalent to x, (or x) is equivalent to x. 344 | (dispatch first top k)) 345 | 346 | ;; length >= 2 347 | 348 | (((list* 'and rest) _) 349 | ;; (and (or)) --- does not come in here. 350 | (cond 351 | ((find '(or) rest :test 'equal) 352 | ;; the entire AND is unsatisfiable. 353 | (funcall k '(or))) 354 | ((find '(and) rest :test 'equal) 355 | ;; the clause can be ignored. 356 | (dispatch (remove '(and) form :test 'equal) top k)) 357 | (t 358 | (trivia.skip:skip)))) 359 | 360 | (((list* 'and rest) t) 361 | ;; if top=t, we are in a toplevel AND, which is allowed in CNF. 362 | ;; Continuations are cut and evaluated immediately. 363 | ;; 364 | ;; note: each dispatch for AND returns a list which lacks AND as the first element. 365 | (funcall k `(and ,@(mappend (lambda (e) 366 | ;; (format *trace-output* "~&Top AND callback~%") 367 | (match (dispatch e t #'identity) 368 | ((list* 'and rest) rest) 369 | (it (list it)))) 370 | rest)))) 371 | 372 | (((list* 'and first rest) nil) 373 | ;; Otherwise, we are inside ORs -- now we are at X of (and P (or Q X=(and A B C) R ) S ). 374 | ;; we must turn this inside-out, i.e.: 375 | ;; (and P (or Q X=A R ) (or Q X=B R ) (or Q X=C R ) S ). 376 | ;; We call the continuation k to obtain the substitutions. 377 | ;; continuation k is a function that returns a form (or Q X R ) given X, thus we call it with each element. 378 | (dispatch first t 379 | (lambda (result1) 380 | ;; (format *trace-output* "~&AND callback in OR~%") 381 | (match* ((funcall k result1) ; == process A --> (or Q A R) 382 | (dispatch `(and ,@rest) nil k)) ; == process (and B C) --> (and (or Q B R) (or Q C R)) 383 | ;; merge ANDs while removing redundancy 384 | (('(and) it) it) 385 | ((it '(and)) it) 386 | (('(or) _) '(or)) 387 | ((_ '(or)) '(or)) 388 | (((list* 'and result1) (list* 'and result2)) 389 | `(and ,@result1 ,@result2)) 390 | ((it (list* 'and result2)) ; <-- above case ends up here 391 | `(and ,it ,@result2)) 392 | (((list* 'and result1) it) 393 | `(and ,@result1 ,it)) 394 | ((it1 it2) 395 | `(and ,it1 ,it2)))))) 396 | 397 | (((list* 'or rest) _) 398 | ;; (or (and)) --- does not come in here. 399 | (cond 400 | ((find '(and) rest :test 'equal) 401 | ;; the entire OR is always satisfiable. 402 | (funcall k '(and))) 403 | ((find '(or) rest :test 'equal) 404 | ;; the clause can be ignored. 405 | (dispatch (remove '(or) form :test 'equal) top k)) 406 | (t 407 | (trivia.skip:skip)))) 408 | 409 | (((list* 'or first rest) _) 410 | (dispatch first nil 411 | (lambda (result1) 412 | ;; (format *trace-output* "~& entered the 1st OR callback: ~a ~%" result1) 413 | (dispatch `(or ,@rest) nil 414 | (lambda (result2) 415 | ;; (format *trace-output* "~& entered the 2nd OR callback: ~a ~%" result2) 416 | (funcall k 417 | (progn 418 | ;; format1 *trace-output* "~& continue: ~a ~%" 419 | (match* (result1 result2) 420 | ;; merge ORs while removing redundancy 421 | (('(or) it) it) 422 | ((it '(or)) it) 423 | (('(and) _) '(and)) 424 | ((_ '(and)) '(and)) 425 | (((list* 'or result1) (list* 'or result2)) 426 | `(or ,@result1 ,@result2)) 427 | ((it (list* 'or result2)) 428 | `(or ,it ,@result2)) 429 | (((list* 'or result1) it) 430 | `(or ,@result1 ,it)) 431 | ((it1 it2) 432 | `(or ,it1 ,it2)))))))))) 433 | (((symbol) _) 434 | (funcall k form)))) 435 | 436 | (defun to-cnf-naive (nnf) 437 | "Convert a NNF into a flattened CNF via a naive method." 438 | (dispatch nnf t #'identity)) 439 | 440 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 441 | ;; Tseytin transformation 442 | 443 | (defun to-cnf-tseytin (form) 444 | "Convert a NNF into a flattened CNF. 445 | OR branches containing ANDs that could result in an exponential CNF 446 | are converted into a linear-sized equisatisfiable formula 447 | via Tseytin transformation by Tseytin 1968. 448 | 449 | aux-variables are generated in CL-SAT.AUX-VARIABLES package. 450 | 451 | G.S. Tseytin: On the complexity of derivation in propositional calculus. Presented at the Leningrad Seminar on Mathematical Logic held in September 1966. 452 | 453 | " 454 | (let ((aux-var-index -1) 455 | (subformulas (make-hash-table :test 'equal)) 456 | conjunctions) 457 | ;; collect subformulas 458 | (labels ((aux+ () (aux (incf aux-var-index))) 459 | (rec (form) 460 | (match form 461 | ((list (or 'and 'or) single) 462 | (rec single)) 463 | ((list* (and op (or 'and 'or)) rest) 464 | (let ((aux (ensure-gethash form subformulas (aux+))) 465 | (substituted (mapcar #'rec rest))) 466 | ;; add a new formula: (aux <=> substituted) 467 | ;; = ((aux => substituted) && (aux <= substituted)) 468 | ;; = (and (or (not aux) substituted) (or aux (not substituted))) 469 | (ecase op 470 | (and 471 | ;; (or (not aux) (and a b c)) = (and (or (not aux) a) (or (not aux) b) (or (not aux) c)) 472 | (dolist (var substituted) 473 | (push `(or ,(negate aux) ,var) conjunctions)) 474 | 475 | ;; (or aux (not (and a b c))) = (or aux (not a) (not b) (not c)) 476 | (push `(or ,aux ,@(mapcar #'negate substituted)) conjunctions)) 477 | 478 | (or 479 | ;; (or (not aux) (or a b c)) = (or aux a b c) 480 | (push `(or ,(negate aux) ,@substituted) conjunctions) 481 | 482 | ;; (or aux (not (or a b c))) = (or aux (and (not a) (not b) (not c))) = (and (or aux (not a)) (or aux (not b)) (or aux (not c))) 483 | (dolist (var substituted) 484 | (push `(or ,aux ,(negate var)) conjunctions)))) 485 | aux)) 486 | (_ 487 | ;; return literals as it is 488 | form)))) 489 | (push (rec form) conjunctions)) 490 | `(and ,@conjunctions))) 491 | 492 | 493 | (defun to-cnf (form &optional (converter #'to-cnf-tseytin)) 494 | "Translates the results to a CNF. 495 | Calls SYMBOLICATE-FORM and TO-NNF internally. 496 | CONVERTER argument specifies which algorithm to use for the conversion, default: #'to-cnf-tseytin." 497 | (funcall converter 498 | (to-nnf 499 | (symbolicate-form form)))) 500 | --------------------------------------------------------------------------------