#-(and) "
P47 (*) Truth tables for logical expressions (2).
Continue problem P46 by defining and/2, or/2, etc as being
operators. This allows to write the logical expression in the more
natural way, as in the example: A and (A or not B). Define
operator precedence as usual; i.e. as in Java.
Example:
* table(A,B, A and (A or not B)).
true true true
true fail true
fail true fail
fail fail fail
"
;; Again, this question doesn't make much sense in lisp.
;;
;; To have fun, we could interpret it as requesting parsing a list in
;; infix notation and translating it to prefix notation.
;;
;; (infix-to-prefix '(a and (a or not b))) --> (and a (or a (not b)))
;;
;; but notice that we need a list anyways, and that parenthesized
;; subexpressions are actually sublists, there's no parentheses to be
;; parsed.
;;
;; On the other hand, we could write a full lexer and parser for
;; prolog syntax, but that would be out of scope for this exercise.
;;
;;
;; Java operator precedences are:
;;
;; Priority Operators Operation Associativity
;; 1 [ ] array index left
;; () method call
;; . member access
;; 2 ++ pre- or postfix increment right
;; -- pre- or postfix decrement
;; + - unary plus, minus
;; ~ bitwise NOT
;; ! boolean (logical) NOT
;; (type) type cast
;; new object creation
;; 3 * / % multiplication, division, remainder left
;; 4 + - addition, substraction left
;; + string concatenation
;; 5 << signed bit shift left left
;; >> signed bit shift right
;; >>> unsigned bit shift right
;; 6 < <= less than, less than or equal to left
;; > >= greater than, greater than or equal to
;; instanceof reference test
;; 7 == equal to left
;; != not equal to
;; 8 & bitwise AND left
;; & boolean (logical) AND
;; 9 ^ bitwise XOR left
;; ^ boolean (logical) XOR
;; 10 | bitwise OR left
;; | boolean (logical) OR
;; 11 && boolean (logical) AND left
;; 12 || boolean (logical) OR left
;; 13 ? : conditional right
;; 14 = assignment right
;; *= /= += -= %=
;; <<= >>= >>>=
;; &= ^= |= combinated assignment
;; (operation and assignment)
;;
;; There are no NAND, NOR, EQU, or IMPL, but there are several AND and
;; OR, with different precedences! What a fucking problem statement!
;;
;; So we will write a parser that is parameterized by the precedences,
;; and we'll see later what is needed.
;; For this, we use a simple recursive-descend parser generator:
(load "rdp.lisp")
(use-package :com.informatimago.rdp)
;; Prefix or suffix operators must have arity = 1, and therefore
;; don't have any specific associativity dirrection other than their
;; being prefix or suffix.
;; x not not not not/1 suffix (((x not) not) not)
;; not not not x not/1 prefix (not (not (not x)))
;; Infix operators must have an arity > 1 (usually 2), and must have
;; either left or right associativity.
;;
;; a op b op c op/2 left (a op b) op b
;; a op b op c op/2 right a op (b op c)
;; We define an operator level as a list containing the precedence
;; level (smaller number, higher precendence), the arity, the
;; position-and-associativity (:prefix, :suffix, :infix-left or
;; :infix-right), and the list of operators:
(defstruct (level (:type list))
(precedence 0 :type integer)
(arity 0 :type integer)
(position :prefix :type (member :prefix :suffix :infix-left :infix-right))
(operators '() :type list))
(defun leftify (operators expr)
"
Transforms a right-associative operation tree EXPR of OPERATORS, into
a leflt-associative one. (op a (op b c)) --> (op (op a b) c)
"
(labels ((flatten (expr flattened)
(cond
((atom expr) (cons expr flattened))
((member (first expr) operators)
(flatten (third expr) (list* (first expr) (second expr) flattened)))
(t (cons expr flattened))))
(unflatten-left (expr flattened)
(if (endp flattened)
expr
(unflatten-left (list (first flattened) expr (second flattened))
(rest (rest flattened))))))
(let ((flattened (nreverse (flatten expr '()))))
(unflatten-left (first flattened) (rest flattened)))))
(defun production-var (n)
"Makes a production variable $n"
(intern (format nil "$~A" n)))
(defun token-to-lisp (token)
;; rdp tokens are (terminal "text" position)
;; Since we take care of naming our operator terminals as lisp
;; operators, we can just extract them from the tokens.
;; For variables, we cl:read the text.
(if (atom token)
token
(case (first token)
((identifier) (read-from-string (second token)))
((true) 't)
((fail) 'nil)
(otherwise (first token)))))
(defun generate-operator-level-rules (non-terminal inferior-non-terminal level)
"Generates a grammar rule to parse the given operator level, and
build the corresponding expression tree."
(let ((op-non-terminal (intern (format nil "~A-OP" non-terminal))))
(ecase (level-position level)
((:prefix)
`((--> ,non-terminal
(alt ,op-non-terminal ,inferior-non-terminal)
:action $1)
(--> ,op-non-terminal
(alt ,@(level-operators level))
,@(make-list (level-arity level) :initial-element inferior-non-terminal)
;; (opt (seq (alt ,@(level-operators level))
;; ,@(make-list (level-arity level) :initial-element inferior-non-terminal))
;; ,inferior-non-terminal)
:action (list (token-to-lisp $1)
,@(loop
:repeat (level-arity level)
:for i :from 2 :collect (production-var i))))))
((:suffix)
`((--> ,non-terminal
(alt ,op-non-terminal ,inferior-non-terminal)
:action $1)
(--> ,op-non-terminal
,@(make-list (level-arity level) :initial-element inferior-non-terminal)
(alt ,@(level-operators level))
:action (list (token-to-lisp ,(production-var (1+ (level-arity level))))
,@(loop
:repeat (level-arity level)
:for i :from 1 :collect (production-var i))))))
;; We're using a recursive-descend parser, so we can have only
;; right-recursive rules. Therefore we will just collect the list
;; of operations at the grammar level, and implement the
;; associativity in the action.
;;
;; (--> factor
;; term op factor) ; :infix-right term op (term op term)
;;
;; (--> factor
;; factor op term) ; :infix-left (term op term) op term
((:infix-left :infix-right)
(assert (= 2 (level-arity level))
(level) "Infix operators with an arity different from 2 are not implemented.")
`((--> ,non-terminal
,op-non-terminal
:action ,(if (eql :infix-left (level-position level))
`(if (and (listp $1) (= 3 (length $1)))
(leftify ',(level-operators level) $1)
$1)
`$1))
(--> ,op-non-terminal
,inferior-non-terminal (opt (alt ,@(level-operators level)) ,op-non-terminal)
:action (if $2
(destructuring-bind (op right) $2
(list (token-to-lisp op) $1 right))
$1)))))))
(defun generate-operator-grammar (name operator-levels)
"Generate a RDP grammar for the operators given in OPERATOR-LEVELS.
This will create a function named PARSE-{NAME}."
(let* ((levels (sort (copy-list operator-levels) (function >)
:key (function level-precedence)))
(non-terminals (nconc (loop
:for level :in levels
:collect (intern (format nil "~{~A~^/~}-FACTOR" (level-operators level))))
(list 'term)))
(terminals (nconc (mapcan (lambda (level)
(mapcar (lambda (operator) (list operator (string-downcase operator)))
(level-operators level)))
levels)
'((true "true")
(fail "fail")
(identifier "[A-Za-z][-A-Za-z0-9]*"))))
(rules `((--> ,(first (last non-terminals))
(alt constant variable parenthesized-expression)
:action $1)
;; We need to wrap terms in an identity operator to
;; avoid lefitification of the first non-terminal:
;; (a impl b) impl (c impl d) must stay that way.
(--> parenthesized-expression
"(" ,(first non-terminals) ")"
:action (list 'identity $2))
(--> constant (alt true fail)
:action (token-to-lisp $1))
(--> variable identifier
:action (token-to-lisp $1))
,@(reduce (function append)
(mapcar (function generate-operator-level-rules)
non-terminals
(rest non-terminals)
levels)
:from-end t))))
#+debug
(print `(com.informatimago.rdp:generate-grammar
,name
:terminals ',terminals
:start ',(first non-terminals)
:rules ',rules))
(com.informatimago.rdp:generate-grammar
name
:terminals terminals
:start (first non-terminals)
:rules rules)))
(defparameter *operators* '(( 2 1 :prefix (not))
( 8 2 :infix-left (and nand))
( 9 2 :infix-left (xor equ))
(10 2 :infix-left (or nor))
(12 2 :infix-left (impl))))
(generate-operator-grammar 'logical-expression *operators*)
(defun test/operator-grammar ()
(loop
:for (source expected)
:in '(("a" a)
("true" t)
("fail" nil)
("a and b" (and a b))
("(a impl b) impl (c impl d)" (impl (identity (impl a b)) (identity (impl c d))))
("a and b and c and d" (AND (AND (AND a b) c) D))
("a and b and c or d and e and f or g and i and j"
(or (or (and (and a b) c) (and (and d e) f)) (and (and g i) j)))
("(a xor b) equ (not a xor not b)"
(equ (identity (xor a b)) (identity (xor (not a) (not b))))))
:do (let ((result (handler-case (PARSE-LOGICAL-EXPRESSION source)
(error (err) (princ err) (terpri) :error))))
(assert (equal result expected)
(source)
"Parsing the logical expression ~S~% gave ~S ~%instead of expected ~S"
source result expected)))
:success)
(defun remove-identity (expr)
(cond
((atom expr) expr)
((eql 'identity (first expr)) (remove-identity (second expr)))
(t (cons (first expr) (mapcar (function remove-identity) (rest expr))))))
;; (table 'a 'b (remove-identity (parse-logical-expression "a and (a or not b)")))
;; true true true
;; true fail true
;; fail true fail
;; fail fail fail
;; --> NIL
;;;; THE END ;;;;