<commit_before>(in-package :thierry-technologies.com/2011/07/lambda)

#| Extensions to the lambda-calculus |#

(defclass lisp-function (scalar hidden-abstraction)
  ((function :reader lisp-fun :initarg :fun)))

(defmethod abs-var ((object lisp-function))
  object) ; for identification purposes, cf. beta-reduce

(defmethod abs-body ((object lisp-function))
  object)

(defmethod expr-free ((object lisp-function))
  nil)
   
(defmacro make-function (name args return &body body)
  `(make-instance 'lisp-function :name ,name :fun
		  ,(named-let rec ((args args))
			      (destructuring-bind (var conv) (first args)
				(labels ((conv-lambda (expr)
					   `(lambda (,var)
					      (let ((,var (,conv ,var)))
						,expr))))
				  (if (rest args)
				      (conv-lambda (rec (rest args)))
				      (conv-lambda `(,return (progn ,@body)))))))))

(defmethod normal-order ((expression lisp-function))
  nil)

(defmethod applicative-order ((expression lisp-function))
  nil)

(defmethod beta-reduce (variable value (expression lisp-function))
  (if (eq variable expression) ; cf. abs-var
      (let ((result (funcall (lisp-fun expression) value)))
	(if (functionp result)
	    (make-instance 'lisp-function :fun result
			   :name (let ((current (hid-name expression)))
				   (if (listp current)
				       (append (butlast current)
					       (list (render value))
					       (last current))
				       (list current (render value) '…))))
	    result))
      expression))<commit_msg>Added type checking and decoding, used decoding in Lisp functions.<commit_after>(in-package :thierry-technologies.com/2011/07/lambda)

#| Extensions to the lambda-calculus |#

(defgeneric decode (expression type environment)
  (:documentation "Returns the Lisp object encoded by the expression in the environment, with type as a hint."))

(defmethod decode ((expression hidden-abstraction) type environment)
  (hid-name expression))

(defmethod decode ((expression hidden-abstraction) (type (eql 'boolean)) environment)
  (read-from-string (render (normalize #'normal-order (make-expression (list expr t nil) nil))) nil))

;;;

(defgeneric %type? (expression type environment)
  (:documentation "Returns wether the expression satisfies the type in this environment."))

(defun type? (expression type &optional (environment *environment*))
  (%type? expression type environment))

(defmethod %type? (expression (type (eql 'numeral)) environment)
  (typep (decode expression type environment) '(integer 0 *)))

(defmethod %type? (expression (type (eql 't)) environment)
  t)

;;;

(defclass lisp-function (scalar hidden-abstraction)
  ((function :reader lisp-fun :initarg :fun)
   (argument-types :reader lisp-args :initarg :args)))

(defmethod abs-var ((object lisp-function))
  object) ; for identification purposes, cf. beta-reduce

(defmethod abs-body ((object lisp-function))
  object)

(defmethod expr-free ((object lisp-function))
  nil)
   
(defmacro make-function (name args &body body)
  (let ((args (mapcar (lambda (arg) (if (consp arg) arg (list arg t))) args)))
    `(make-instance 'lisp-function :name ,name :args ',(mapcar #'second args)
		    :fun ,(named-let rec ((args args))
				     (destructuring-bind (var type) (first args)
				       (labels ((conv-lambda (expr)
						  `(lambda (,var)
						     (let ((,var (decode ,var ',type *environment*)))
						       ,expr))))
					 (if (rest args)
					     (conv-lambda (rec (rest args)))
					     (conv-lambda `(make-expression (progn ,@body))))))))))

(defmethod normal-order ((expression lisp-function))
  nil)

(defmethod applicative-order ((expression lisp-function))
  nil)

(defmethod beta-reduce (variable value (expression lisp-function))
  (if (eq variable expression) ; cf. abs-var
      (let ((result (funcall (lisp-fun expression) value)))
	(if (functionp result)
	    (make-instance 'lisp-function :fun result :args (rest (lisp-args expression))
			   :name (let ((current (hid-name expression)))
				   (if (listp current)
				       (append (butlast current)
					       (list (render value))
					       (last current))
				       (list current (render value) '…))))
	    result))
      expression))
{'fraction_non_alphanumeric': 0.142411891632702, 'fraction_numerical': 0.0031167585710860706, 'mean_word_length': 3.6048565121412803, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 3, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2523474', 'n_tokens_mistral': 1400, 'n_tokens_neox': 1245, 'n_words': 403}