;;;;; TRE to ECMAScript transpiler
;;;;; Copyright (c) 2009 Sven Klose <pixel@copei.de>

(defun hash-table? (x)
  (and (objectp x)
       (undefined? x.__class)))

(defun hash-assoc (x)
  (let lst nil
    (maphash #'((k v)
				  (push! (cons k v) lst))
         	 x)
    (reverse lst)))

;; XXX test is ignored.
(defun assoc-hash (x &key (test nil))
  (let h (make-hash-table)
    (dolist (i x h)
      (setf (href h i.) .i))))

;;;;; TRE to ECMAScript transpiler
;;;;; Copyright (c) 2009-2010 Sven Klose <pixel@copei.de>

(defun hash-table? (x)
  (and (objectp x)
       (undefined? x.__class)))

(defun hash-assoc (x)
  (let lst nil
    (maphash #'((k v)
				  (push! (cons k v) lst))
         	 x)
    (reverse lst)))

;; XXX test is ignored.
(defun assoc-hash (x &key (test #'eql))
  (let h (make-hash-table :test test)
    (dolist (i x h)
      (setf (href h i.) .i))))

Use default values for keyword arguments.


;;;;; Copyright (c) 2012–2014 Sven Michael Klose <pixel@copei.de>

(defvar *contact-to*)
(defvar *contact-subject*)

(defun contact-mail-header ()
  (alet (@ (form-data) 'email)
    (+ "From: " ! *terpri*
       "Reply-To: " ! *terpri*)))

(defun send-contact-mail ()
  (mail *contact-to* *contact-subject*
        (@ (form-data) 'text)
        (contact-mail-header))
  (action-redirect :add 'contactdone))

(defun contact (x)
  (?
    (form-complete?) (send-contact-mail)
    (has-form?)      (= (page-status) (lang de "Das Formular ist unvollständig."
                                            en "Sorry, but the form is incomplete.")))
  (set-port (tpl-navigation-contact))
  1)

(define-action contact :group contact)

(define-redirect-catcher (contactdone :status (lang de "Ihre Nachricht wurde versendet."
                                                    en "Your message has been sent.")))
(set-action-group 'contactdone 'contact)

; Copyright (c) 2012–2014,2016 Sven Michael Klose <pixel@copei.de>

(defvar *contact-to*)
(defvar *contact-subject*)

(defun contact-mail-header ()
  (alet (href (form-data) 'email)
    (+ "From: " ! *terpri*
       "Reply-To: " ! *terpri*)))

(defun send-contact-mail ()
  (mail *contact-to* *contact-subject*
        (href (form-data) 'text)
        (contact-mail-header))
  (action-redirect :add 'contactdone))

(defun contact (x)
  (?
    (form-complete?) (send-contact-mail)
    (has-form?)      (= (page-status) (lang de "Das Formular ist unvollständig."
                                            en "Sorry, but the form is incomplete.")))
  (set-port (tpl-navigation-contact))
  1)

(define-action contact :group contact)

(define-redirect-catcher (contactdone :status (lang de "Ihre Nachricht wurde versendet."
                                                    en "Your message has been sent.")))
(set-action-group 'contactdone 'contact)

Fix access to form data array.

Fix access to form data array.


(cl:in-package #:asdf-user)

(defsystem :sicl-format-test
  :depends-on (:lisp-unit :sicl-format)
  :components
  ((:file "format-test" :depends-on ())))

(cl:in-package #:asdf-user)

(defsystem :sicl-format-test
  :depends-on (:lisp-unit :sicl-format)
  :serial t
  :components
  ((:file "format-test")))

Use option :SERIAL T for test system.

Use option :SERIAL T for test system.


(in-package #:factual.core)

(defclass deb-package ()
  ((depends :accessor depends :initform nil)
   (data-files :accessor data-files :initform nil)))

(defclass node ()
  ((name :accessor name :initarg :name :type string)
   (path :reader path :initarg :path :type pathname)
   (packages :accessor packages :type list)
   (variables :accessor variables :type list :initform nil)))

(defclass variable ()
  ((package :initarg :package :reader package)
   (name :initarg :name :reader name)
   (value :initarg :value :reader value)))

(defmethod deb-pathname ((node node))
  (pathname
   (format nil "~A_~A.deb"
           (name node)
           (local-time:format-rfc3339-timestring nil (local-time:now)))))

(in-package #:factual.core)

(defclass deb-package ()
  ((depends :accessor depends :initform nil)
   (data-files :accessor data-files :initform nil)))

(defclass node ()
  ((name :accessor name :initarg :name :type string)
   (path :reader path :initarg :path :type pathname)
   (packages :accessor packages :type list)
   (variables :accessor variables :type list :initform nil)))

(defclass variable ()
  ((package :initarg :package :reader package)
   (name :initarg :name :reader name)
   (value :initarg :value :reader value)))

(defmethod deb-pathname ((node node))
  (pathname
   (format nil "~A_~{~A~^-~}.deb"
           (name node)
           (let ((now (local-time:now)))
             (list (local-time:timestamp-year now)
                   (local-time:timestamp-month now)
                   (local-time:timestamp-day now)
                   (local-time:timestamp-hour now)
                   (local-time:timestamp-minute now)
                   (local-time:timestamp-second now))))))

Define a better deb package name.

Define a better deb package name.


(cl:in-package #:clump-binary-tree)

(defgeneric iterative-traversal (tree enter))

(defmethod iterative-traversal ((tree node-with-parent) enter leave)
  (let ((current-node tree))
    (loop do (if (or (not (funcall enter current-node))
		     (and (null (left current-node))
			  (null (right current-node))))
		 (loop for parent = (parent current-node)
		       until (or (null parent)
				 (and (eq current-node (left parent))
				      (not (null (right parent)))))
		       do (setf current-node parent)
		       finally (if (null parent)
				   (return-from iterative-traversal)
				   (setf current-node (right parent))))
		 (setf current-node
		       (or (left current-node)
			   (right current-node)))))))

(cl:in-package #:clump-binary-tree)

(defgeneric iterative-traversal (tree enter))

(defmethod iterative-traversal ((tree node-with-parent) enter leave)
  (let ((current-node tree))
    (loop do (if (or (not (funcall enter current-node))
		     (and (null (left current-node))
			  (null (right current-node))))
		 (loop for parent = (parent current-node)
		       until (or (null parent)
				 (and (eq current-node (left parent))
				      (not (null (right parent)))))
		       do (funcall leave current-node)
			  (setf current-node parent)
		       finally (if (null parent)
				   (return-from iterative-traversal)
				   (setf current-node (right parent))))
		 (setf current-node
		       (or (left current-node)
			   (right current-node)))))))

Call function LEAVE when moving up the tree.


(defpackage :coleslaw
  (:documentation "Homepage: Github")
  (:use :cl)
  (:import-from :alexandria #:hash-table-values
                            #:make-keyword
                            #:mappend)
  (:import-from :closure-template #:compile-template)
  (:export #:main
           #:blog
           #:content
           #:post
           #:index
           #:add-injection
           #:render-content
           #:deploy))

(defpackage :coleslaw
  (:documentation "Homepage: Github")
  (:use :cl)
  (:import-from :alexandria #:hash-table-values
                            #:make-keyword
                            #:mappend)
  (:import-from :closure-template #:compile-template)
  (:export #:main
           #:blog
           #:deploy
           #:content
           #:post
           #:index
           #:page-path
           #:discover
           #:publish
           #:render
           #:render-content
           #:add-injection))

Update export list to expose new API.

Update export list to expose new API.


(asdf:defsystem cl-libevent2
  :author "Andrew Danger Lyon <orthecreedence@gmail.com>"
  :license "MIT"
  :version "0.1.5"
  :description "Low-level libevent2 bindings for Common Lisp."
  :depends-on (#:cffi #:cffi-libffi)
  :components ((:file "libevent2")
               (:file "wrapper" :depends-on ("libevent2"))
               (:file "bindings" :depends-on ("wrapper"))
               (:file "exports" :depends-on ("bindings"))
               (:file "accessors" :depends-on ("exports"))))

(asdf:defsystem cl-libevent2
  :author "Andrew Danger Lyon <orthecreedence@gmail.com>"
  :license "MIT"
  :version "0.1.5"
  :description "Low-level libevent2 bindings for Common Lisp."
  :depends-on (#:cffi)
  :components ((:file "libevent2")
               (:file "wrapper" :depends-on ("libevent2"))
               (:file "bindings" :depends-on ("wrapper"))
               (:file "exports" :depends-on ("bindings"))
               (:file "accessors" :depends-on ("exports"))))

Revert "Add the system CFFI-LIBFFI to ASDF dependencies."

This reverts commit 2bf722c0748076a954c57e2d30edc90067653d52.


(cl:defpackage #:cartesian-product-switch_tests
  (:use #:cl #:parachute)
  (:import-from #:cartesian-product-switch #:cartesian-product-switch))

(cl:in-package #:cartesian-product-switch_tests)

(define-test "featured-example"
  (flet ((test (manner direction expected)
           (flet ((invoke ()
                    (cartesian-product-switch ((case manner
                                                 :walk
                                                 :flip)
                                               (case direction
                                                 :forward
                                                 :in-place
                                                 :backward))
                      "Walking..."
                      (error "Walking in-place is too boring!")
                      "Awkwardly walking backwards..."
                      "Frontflip!"
                      "Jumping in-place."
                      "Backflip!"
                      (t (error "Don't know how to ~A while going ~A." manner direction)))))
             (etypecase expected
               (string (is string= (invoke) expected))
               ((eql error) (fail (invoke)))))))
    (test :walk :forward "Walking...")
    (test :walk :in-place 'error)
    (test :walk :backward "Awkwardly walking backwards...")
    (test :flip :forward "Frontflip!")
    (test :flip :in-place "Jumping in-place.")
    (test :flip :backward "Backflip!")
    (test :crawl :forward 'error)
    (test :flip :sideways 'error)))

;;; TODO: Test other testclause kinds, and custom testclause kind definition.

(cl:defpackage #:cartesian-product-switch_tests
  (:use #:cl #:parachute)
  (:import-from #:cartesian-product-switch #:cartesian-product-switch))

(cl:in-package #:cartesian-product-switch_tests)

(define-test "featured-example"
  (flet ((test (manner direction expected)
           (flet ((invoke ()
                    (cartesian-product-switch ((case manner
                                                 :walk
                                                 :flip)
                                               (case direction
                                                 :forward
                                                 :in-place
                                                 :backward))
                      "Walking..."
                      (error "Walking in-place is too boring!")
                      "Awkwardly walking backwards..."
                      "Frontflip!"
                      "Jumping in-place."
                      "Backflip!"
                      (t (error "Don't know how to ~A while going ~A." manner direction)))))
             (etypecase expected
               (string (is string= expected (invoke)))
               ((eql error) (fail (invoke)))))))
    (test :walk :forward "Walking...")
    (test :walk :in-place 'error)
    (test :walk :backward "Awkwardly walking backwards...")
    (test :flip :forward "Frontflip!")
    (test :flip :in-place "Jumping in-place.")
    (test :flip :backward "Backflip!")
    (test :crawl :forward 'error)
    (test :flip :sideways 'error)))

;;; TODO: Test other testclause kinds, and custom testclause kind definition.

Use proper argument order for IS.

Tests: Use proper argument order for IS.


(cl:in-package #:sicl-extrinsic-hir-interpreter)

(defclass enter-instruction (cleavir-ir:enter-instruction)
  ((%owned-variables :initarg :owned-variables :reader owned-variables)))

(defun lexical-value (lexical-variable process)
  (loop for table in (static-env (stack process))
	do (multiple-value-bind (value present-p)
	       (gethash lexical-variable table)
	     (when present-p
	       (return-from lexical-value value))))
  (error "unknown variable ~s" lexical-variable))

(defun (setf lexical-value) (value lexical-variable process)
  (loop for table in (static-env (stack process))
	do (multiple-value-bind (old-value present-p)
	       (gethash lexical-variable table)
	     (declare (ignore old-value))
	     (when present-p
	       (setf (gethash lexical-variable table) value)
	       (return-from lexical-value)))))

Set the value of a lexical variable in the current process.


(cl:in-package #:cleavir-ast-to-hir)

(defmethod compile-ast ((ast cleavir-ast:speed-ast) context)
  (compile-ast (cleavir-ast:child-ast ast)
	       (clone-context context
			      :speed-value (cleavir-ast:value ast))))

(defmethod compile-ast ((ast cleavir-ast:debug-ast) context)
  (compile-ast (cleavir-ast:child-ast ast)
	       (clone-context context
			      :debug-value (cleavir-ast:value ast))))

Define method on COMPILE-AST specialized to DEBUG-AST.


(cl:in-package #:cleavir-simple-value-numbering)

;;; We attribute a unique number to each value designator.  That way,
;;; we can keep the value designators in a partition sorted by the
;;; unique number which makes operations on partitions faster.
;;;
;;; This variable should be bound to some small integer at the
;;; beginning of processing.
(defvar *unique-number*)

;;; We use instances of this class to designate values.
(defclass value-designator () ())

;;; This variable holds and EQ hash table mapping constants to value
;;; designators.
(defvar *constant-designators*)

(defun constant-designator (constant)
  (let ((result (gethash constant *constant-designators*)))
    (when (null result)
      (setf result (make-instance 'value-designator))
      (setf (gethash constant *constant-designators*) result))
    result))

;;  LocalWords:  designator designators

(cl:in-package #:cleavir-simple-value-numbering)

;;; We attribute a unique number to each value designator.  That way,
;;; we can keep the value designators in a partition sorted by the
;;; unique number which makes operations on partitions faster.
;;;
;;; This variable should be bound to some small integer at the
;;; beginning of processing.
(defvar *unique-number*)

;;; We use instances of this class to designate values.
(defclass value-designator ()
  ((%unique-number :initform (incf *unique-number*) :reader unique-number)))

;;; This variable holds and EQ hash table mapping constants to value
;;; designators.
(defvar *constant-designators*)

(defun constant-designator (constant)
  (let ((result (gethash constant *constant-designators*)))
    (when (null result)
      (setf result (make-instance 'value-designator))
      (setf (gethash constant *constant-designators*) result))
    result))

;;  LocalWords:  designator designators

Add a slot to the VALUE-DESIGNATOR class for unique number.


;;;; © 2016-2019 Marco Heisig         - license: GNU AGPLv3 -*- coding: utf-8 -*-

(in-package #:petalisp.graphviz)

(defparameter *graphviz-default-viewer*
  (flet ((program-in-path-p (program)
           (multiple-value-bind (out err exit-code)
               (uiop:run-program
                (list "which" program)
                :ignore-error-status t)
             (declare (ignore out err))
             (zerop exit-code))))
    (find-if #'program-in-path-p '("okular" "evince" "xpdf"))))

(defparameter *graphviz-default-format* :pdf)

(defun view (graph-root &key
                          (format *graphviz-default-format*)
                          (viewer *graphviz-default-viewer*)
                          (graph (graphviz-default-graph graph-root)))
  (when (symbolp graph)
    (setf graph (make-instance graph)))
  (uiop:with-temporary-file (:pathname image-file)
    (cl-dot:dot-graph
     (cl-dot:generate-graph-from-roots graph (alexandria:ensure-list graph-root))
     image-file
     :format format)
    (uiop:run-program
     (list viewer (uiop:native-namestring image-file))))
  graph-root)

;;;; © 2016-2019 Marco Heisig         - license: GNU AGPLv3 -*- coding: utf-8 -*-

(in-package #:petalisp.graphviz)

(defparameter *graphviz-default-viewer*
  (flet ((program-in-path-p (program)
           (multiple-value-bind (out err exit-code)
               (uiop:run-program
                (list "which" program)
                :ignore-error-status t)
             (declare (ignore out err))
             (zerop exit-code))))
    (find-if #'program-in-path-p '("okular" "evince" "xpdf"))))

(defparameter *graphviz-default-format* :pdf)

(defun view (graph-root &key
                          (format *graphviz-default-format*)
                          (viewer *graphviz-default-viewer*)
                          (graph (graphviz-default-graph graph-root)))
  (when (symbolp graph)
    (setf graph (make-instance graph)))
  (uiop:with-temporary-file (:pathname image-file)
    (cl-dot:dot-graph
     (cl-dot:generate-graph-from-roots graph (alexandria:ensure-list graph-root) '(:margin 0.0))
     image-file
     :format format)
    (uiop:run-program
     (list viewer (uiop:native-namestring image-file))))
  graph-root)

Set the margin of Graphviz graphs to zero.


(in-package :coleslaw)

(defclass post (content)
  ((title :initform nil :initarg :title :accessor post-title)
   (author :initform nil :initarg :author :accessor post-author)
   (format :initform nil :initarg :format :accessor post-format)))

(defmethod initialize-instance :after ((object post) &key)
  (with-accessors ((title post-title)
                   (author post-author)
                   (format post-format)
                   (text content-text)) object
      (setf (content-slug object) (slugify title)
            format (make-keyword (string-upcase format))
            text (render-content text format)
            author (if author
                       author
                       (author *config*)))))

(defmethod render ((object post) &key prev next)
  (funcall (theme-fn 'post) (list :config *config*
                                  :post object
                                  :prev prev
                                  :next next)))

(defmethod page-url ((object post))
  (format nil "~a/~a" (posts-dir *config*) (content-slug object)))

(defmethod publish ((content-type (eql :post)))
  (loop for (next post prev) on (append '(nil) (by-date (find-all 'post)))
     while post do (write-page (page-path post)
                               (render-page post nil :prev prev :next next))))

(in-package :coleslaw)

(defclass post (content)
  ((title :initform nil :initarg :title :accessor post-title)
   (author :initform nil :initarg :author :accessor post-author)
   (format :initform nil :initarg :format :accessor post-format)))

(defmethod initialize-instance :after ((object post) &key)
  (with-accessors ((title post-title)
                   (author post-author)
                   (format post-format)
                   (text content-text)) object
      (setf (content-slug object) (slugify title)
            format (make-keyword (string-upcase format))
            text (render-content text format)
            author (or author (author *config*)))))

(defmethod render ((object post) &key prev next)
  (funcall (theme-fn 'post) (list :config *config*
                                  :post object
                                  :prev prev
                                  :next next)))

(defmethod page-url ((object post))
  (format nil "~a/~a" (posts-dir *config*) (content-slug object)))

(defmethod publish ((content-type (eql :post)))
  (loop for (next post prev) on (append '(nil) (by-date (find-all 'post)))
     while post do (write-page (page-path post)
                               (render-page post nil :prev prev :next next))))

Use OR to guard instead of IF.

Use OR to guard instead of IF.


;;;; Copyright (c) 2008 - 2013
;;;;
;;;;     Robert Strandh (robert.strandh@gmail.com)
;;;;
;;;; all rights reserved.
;;;;
;;;; Permission is hereby granted to use this software for any
;;;; purpose, including using, modifying, and redistributing it.
;;;;
;;;; The software is provided "as-is" with no warranty.  The user of
;;;; this software assumes any responsibility of the consequences.

;;;; This file is part of the conditionals module of the SICL project.
;;;; See the file SICL.text for a description of the project.
;;;; See the file conditionals.text for a description of the module.

(cl:in-package #:common-lisp-user)

(asdf:defsystem :sicl-conditionals-support
  :depends-on (:cleavir-internationalization
	       :cleavir-code-utilities)
  :serial t
  :components
  ((:file "packages")
   (:file "support")
   (:file "conditions")
   (:file "condition-reporters-en")
   (:file "docstrings-en")))

;;;; Copyright (c) 2008 - 2013
;;;;
;;;;     Robert Strandh (robert.strandh@gmail.com)
;;;;
;;;; all rights reserved.
;;;;
;;;; Permission is hereby granted to use this software for any
;;;; purpose, including using, modifying, and redistributing it.
;;;;
;;;; The software is provided "as-is" with no warranty.  The user of
;;;; this software assumes any responsibility of the consequences.

;;;; This file is part of the conditionals module of the SICL project.
;;;; See the file SICL.text for a description of the project.
;;;; See the file conditionals.text for a description of the module.

(cl:in-package #:asdf-user)

(defsystem :sicl-conditionals-support
  :depends-on (:cleavir-internationalization
	       :cleavir-code-utilities)
  :serial t
  :components
  ((:file "packages")
   (:file "support")
   (:file "conditions")
   (:file "condition-reporters-en")
   (:file "docstrings-en")))

Define ASDF system in package ASDF-USER.


(cl:in-package #:sicl-extrinsic-hir-compiler)

(defun rp (filename)
  (asdf:system-relative-pathname :sicl-extrinsic-hir-compiler filename))

(load (rp "../../Evaluation-and-compilation/lambda.lisp"))
(load (rp "../../Environment/multiple-value-bind.lisp"))
(load (rp "../../Data-and-control-flow/setf.lisp"))
(load (rp "../../Environment/defun.lisp"))
(load (rp "../../Environment/standard-environment-macros.lisp"))
(load (rp "../../Data-and-control-flow/fboundp.lisp"))
(load (rp "../../Data-and-control-flow/fdefinition.lisp"))
(load (rp "../../Data-and-control-flow/setf-fdefinition.lisp"))
(load (rp "ensure-generic-function.lisp"))

(cl:in-package #:sicl-extrinsic-hir-compiler)

(defun rp (filename)
  (asdf:system-relative-pathname :sicl-extrinsic-hir-compiler filename))

(load (rp "../../Evaluation-and-compilation/lambda.lisp"))
(load (rp "../../Environment/multiple-value-bind.lisp"))
(load (rp "../../Data-and-control-flow/setf.lisp"))
(load (rp "../../Environment/defun.lisp"))
(load (rp "../../Conditionals/macros.lisp"))
(load (rp "../../Environment/standard-environment-macros.lisp"))
(load (rp "../../Data-and-control-flow/fboundp.lisp"))
(load (rp "../../Data-and-control-flow/fdefinition.lisp"))
(load (rp "../../Data-and-control-flow/setf-fdefinition.lisp"))
(load (rp "ensure-generic-function.lisp"))

Load conditional macros into target environment.


;;;;; tré – Copyright (c) 2008–2013 Sven Michael Klose <pixel@copei.de>

(dont-obfuscate *lexicals* *lexical-id* function_exists call_user_func_array)

(defun apply (&rest lst)
  (with (fun            lst.
         l              (last .lst)
         args           (%nconc (butlast .lst) l.)
         closure?       (is_a fun "__closure")
         fun-name       (? closure?
                           fun.n
                           fun)
         expander-name  (%%%string+ fun-name "_treexp"))
    (& closure?
       (= args (. fun.g args)))
	(?
      (function_exists expander-name)  (call_user_func_array expander-name (%%native "array ($" args ")"))
	  (function_exists fun-name)       (call_user_func_array fun-name (list-phphash args))
      (error (+ "Function '" fun-name "' does not exist.")))))

; tré – Copyright (c) 2008–2013,2015 Sven Michael Klose <pixel@copei.de>

(dont-obfuscate *lexicals* *lexical-id* function_exists call_user_func_array)

(defun apply (&rest lst)
  (with (fun            lst.
         l              (last .lst)
         args           (nconc (butlast .lst) l.)
         closure?       (is_a fun "__closure")
         fun-name       (? closure?
                           fun.n
                           fun)
         expander-name  (%%%string+ fun-name "_treexp"))
    (& closure?
       (= args (. fun.g args)))
	(?
      (function_exists expander-name)  (call_user_func_array expander-name (%%native "array ($" args ")"))
	  (function_exists fun-name)       (call_user_func_array fun-name (list-phphash args))
      (error (+ "Function '" fun-name "' does not exist.")))))

Use NCONC instead of %NCONC.

Use NCONC instead of %NCONC.


(in-package #:sicl-global-environment)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Constant NIL.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (push (make-constant-variable-entry nil nil)
	(constant-variables *global-environment*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Constant T.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (push (make-constant-variable-entry t t)
	(constant-variables *global-environment*)))

(cl:in-package #:sicl-global-environment)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Constant NIL.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (push (make-constant-variable-entry nil nil)
	(constant-variables *global-environment*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Constant T.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (push (make-constant-variable-entry t t)
	(constant-variables *global-environment*)))

Use explicit package marker with IN-PACKAGE.


(cl:in-package #:common-lisp-user)

(asdf:defsystem :cleavir-generate-ast
  :depends-on (:cleavir-ast
	       :cleavir-primop
	       :cleavir-code-utilities
	       :cleavir-environment)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "check-special-form-syntax")
   (:file "minimal-compilation")
   (:file "generate-ast")
   (:file "convert-form")
   (:file "convert-special")
   (:file "convert-primop")))

(cl:in-package #:common-lisp-user)

(asdf:defsystem :cleavir-generate-ast
  :depends-on (:cleavir-ast
	       :cleavir-primop
	       :cleavir-code-utilities
	       :cleavir-environment)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "check-special-form-syntax")
   (:file "environment-query")
   (:file "minimal-compilation")
   (:file "generate-ast")
   (:file "convert-form")
   (:file "convert-special")
   (:file "convert-primop")))

Add locally defined environment query functions as component.


(cl:in-package #:sicl-extrinsic-environment)

(defparameter *trace-funcall* nil)

(defparameter *depth* 0)

(defun traced-funcall (environment function &rest arguments)
  (if *trace-funcall*
      (let* ((entries (sicl-simple-environment::function-entries environment))
	     (entry (block nil
		      (maphash
		       (lambda (key entry)
			 (declare (ignore key))
			 (when (eq function
				   (car (sicl-simple-environment::function-cell entry)))
			   (return entry)))
		       entries)))
	     (name (if (null entry)
		       "???"
		       (sicl-simple-environment::name entry)))
	     (result nil))
	(loop repeat *depth*
	      do (format *trace-output* " "))
	(format *trace-output*
		"calling ~s with arguments: ~s~%" name arguments)
	(let ((*depth* (1+ *depth*)))
	  (setq result (multiple-value-list (apply function arguments))))
	(loop repeat *depth*
	      do (format *trace-output* " "))
	(format *trace-output*
		"~s returned: ~s~%" name result)
	(apply #'values result))
      (apply function arguments)))

(cl:in-package #:sicl-extrinsic-environment)

(defparameter *trace-funcall* nil)

(defparameter *depth* 0)

(defun traced-funcall (environment function &rest arguments)
  (if *trace-funcall*
      (let ((name (or (car (sicl-genv:function-names function environment))
		      "???"))
	    (result nil))
	(loop repeat *depth*
	      do (format *trace-output* " "))
	(format *trace-output*
		"calling ~s with arguments: ~s~%" name arguments)
	(let ((*depth* (1+ *depth*)))
	  (setq result (multiple-value-list (apply function arguments))))
	(loop repeat *depth*
	      do (format *trace-output* " "))
	(format *trace-output*
		"~s returned: ~s~%" name result)
	(apply #'values result))
      (apply function arguments)))

Use new environment function to find function name in trace.


;;; -*- Lisp -*-

(defsystem :split-sequence
  :author "Arthur Lemmens <alemmens@xs4all.nl>"
  :maintainer "Sharp Lispers <sharplispers@googlegroups.com>"
  :description "Splits a sequence into a list of subsequences
  delimited by objects satisfying a test."
  :license "MIT"
  :version (:read-file-form "version.sexp")
  :components ((:static-file "version.sexp")
               (:file "package")
               (:file "vector")
               (:file "list")
               (:file "extended-sequence" :if-feature (:or :sbcl :abcl))
               (:file "api")
               (:file "documentation"))
  :in-order-to ((test-op (test-op :split-sequence/tests))))

(defsystem :split-sequence/tests
  :author "Arthur Lemmens <alemmens@xs4all.nl>"
  :maintainer "Sharp Lispers <sharplispers@googlegroups.com>"
  :description "Split-Sequence test suite"
  :license "MIT"
  :depends-on (:split-sequence :fiveam)
  :components ((:file "tests"))
  :perform (test-op (o c) (symbol-call :5am :run! :split-sequence)))

;;; -*- Lisp -*-

#.(unless (or #+asdf3.1 (version<= "3.1" (asdf-version)))
    (error "You need ASDF >= 3.1 to load this system correctly."))

(defsystem :split-sequence
  :author "Arthur Lemmens <alemmens@xs4all.nl>"
  :maintainer "Sharp Lispers <sharplispers@googlegroups.com>"
  :description "Splits a sequence into a list of subsequences
  delimited by objects satisfying a test."
  :license "MIT"
  :version (:read-file-form "version.sexp")
  :components ((:static-file "version.sexp")
               (:file "package")
               (:file "vector")
               (:file "list")
               (:file "extended-sequence" :if-feature (:or :sbcl :abcl))
               (:file "api")
               (:file "documentation"))
  :in-order-to ((test-op (test-op :split-sequence/tests))))

(defsystem :split-sequence/tests
  :author "Arthur Lemmens <alemmens@xs4all.nl>"
  :maintainer "Sharp Lispers <sharplispers@googlegroups.com>"
  :description "Split-Sequence test suite"
  :license "MIT"
  :depends-on (:split-sequence :fiveam)
  :components ((:file "tests"))
  :perform (test-op (o c) (symbol-call :5am :run! :split-sequence)))

Add ASDF guard to the .asd file

Add ASDF guard to the .asd file


(cl:in-package #:asdf-user)

(defsystem :cleavir-def-use-chains-test
  :depends-on (:cleavir-def-use-chains
	       :cleavir-test-utilities)
  :components
  ((:file "test-packages")
   (:file "test-def-use-chains" :depends-on ("test-packages"))))

(cl:in-package #:asdf-user)

(defsystem :cleavir-def-use-chains-test
  :depends-on (:cleavir-def-use-chains
	       :cleavir-test-utilities)
  :serial t
  :components
  ((:file "test-packages")
   (:file "test-def-use-chains")))

Use option :SERIAL T to simplify system.


(cl:in-package #:clump-binary-tree)

(setf (documentation 'left 'function)
      (format nil "Given a binary tree, return the left child of that tree.~@
                   If an object other than a binary tree is given,~@
                   then an error of type INVALID-BINARY-TREE is signaled."))

(setf (documentation 'right 'function)
      (format nil "Given a binary tree, return the right child of that tree.~@
                   If an object other than a binary tree is given,~@
                   then an error of type INVALID-BINARY-TREE is signaled."))

(setf (documentation '(setf left) 'function)
      (format nil "Given two binary trees, NEW and TREE,~@
                   make NEW the new left child of TREE.~@
                   NEW may be a node or NIL.~@
                   If TREE is NIL an error of type,~@
                   INVALID-BINARY-TREE is signaled."))

Add English documentation for function (SETF LEFT).


(cl:in-package #:common-lisp-user)

(asdf:defsystem :cleavir-register-allocation
  :depends-on (:cleavir-liveness
	       :cleavir-ir
	       :cleavir-hir
	       :cleavir-mir)
  :components
  ((:file "packages")
   (:file "compute-conflicts")
   (:file "graph-coloring")))

(cl:in-package #:asdf-user)

(defsystem :cleavir-register-allocation
  :depends-on (:cleavir-liveness
	       :cleavir-ir
	       :cleavir-hir
	       :cleavir-mir)
  :components
  ((:file "packages")
   (:file "compute-conflicts")
   (:file "graph-coloring")))

Define system in package ASDF-USER.

Define system in package ASDF-USER.


(cl:in-package #:common-lisp-user)

(asdf:defsystem :cleavir-hir-interpreter
  :depends-on (:cleavir-hir
	       :cleavir-hir-transformations
	       :cleavir-basic-blocks)
  :serial t
  :components
  ((:file "packages")
   (:file "translate")))

(cl:in-package #:asdf-user)

(defsystem :cleavir-hir-interpreter
  :depends-on (:cleavir-hir
	       :cleavir-hir-transformations
	       :cleavir-basic-blocks)
  :serial t
  :components
  ((:file "packages")
   (:file "translate")))

Define system in package ASDF-USER.

Define system in package ASDF-USER.


;;;; Copyright (c) 2010 - 2015
;;;;
;;;;     Robert Strandh (robert.strandh@gmail.com)
;;;;
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or
;;;; without modification, are permitted provided that the following
;;;; conditions are met:
;;;;
;;;; 1. Redistributions of source code must retain the above copyright
;;;;    notice, this list of conditions and the following disclaimer.
;;;; 2. Redistributions in binary form must reproduce the above
;;;;    copyright notice, this list of conditions and the following
;;;;    disclaimer in the documentation and/or other materials
;;;;    provided with the distribution.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
;;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
;;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;;; POSSIBILITY OF SUCH DAMAGE.

(cl:in-package #:sicl-clos)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class SIMPLE-METHOD-COMBINATION.

(defclass simple-method-combination (method-combination)
  ((%operation :initarg :operation :reader operation)))

Add copyright dates and license statement.


(defpackage #:clim-mop
  (:use #:clos))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (loop for sym being the symbols of :clim-mop
     do (export sym :clim-mop)))

;; CLIM expects INPUT-STREAM-P to be a generic function.
(unless (typep #'input-stream-p 'generic-function)
  (setf (fdefinition 'gray::original-input-stream-p) #'input-stream-p)
  (fmakunbound 'input-stream-p)
  (defgeneric input-stream-p (stream)
    (:method ((stream stream)) (gray::original-input-stream-p stream))))

;; CLIM expects OUTPUT-STREAM-P to be a generic function.
(unless (typep #'output-stream-p 'generic-function)
  (setf (fdefinition 'gray::original-output-stream-p) #'output-stream-p)
  (fmakunbound 'output-stream-p)
  (defgeneric output-stream-p (stream)
    (:method ((stream stream)) (gray::original-output-stream-p stream))))

Package setup and misc fixes for running on CLISP.


(import extra/test ())
(import extra/assert ())
(import tests/compiler/codegen/codegen-helpers ())

(describe "The codegen will generate syntactically valid Lua for"
  (section "symbols that are"
    (it "empty"
      (affirm-codegen
        ~((define ,(string->symbol "") 2))
        "_e = 2"))
    (pending "numbers"
      (affirm-codegen
        ~((define ,(string->symbol "23") 2))
        "_e23 = 2")
      (affirm-codegen
        (list (string->symbol "23.0"))
        "return _e23"))
    (it "symbols"
      (affirm-codegen
        ~((define ,(string->symbol "a+") 2))
        "a_2b_ = 2")
      (affirm-codegen
        ~((define ,(string->symbol "+-") 2))
        "_2b2d_ = 2"))
    (it "hyphenated"
      (affirm-codegen
        ~((define ,(string->symbol "foo-bar") 2))
        "fooBar = 2")))

  (pending "Adds semi-colons between functions"
    (affirm-codegen
      '((foo) ((cond [foo foo] [true bar])) 1)
      "foo();
       (foo or bar)()
       return 1")))

Add a couple of failign tests for codegen


(in-package :cqlcl)

(defclass connection ()
  ((streams :accessor streams)
   (version :accessor vsn)))

(defclass cql-stream ()
  ((id :accessor id :initarg id)))

Add skeleton for the connection module

Add skeleton for the connection module


(cl:defpackage :csv-filter-test
  (:use :cl :csv-filter :rt)
  (:import-from :rt #:*expected-failures*) )

(rt:rem-all-tests)

Add some skelton of test suite

Add some skelton of test suite


(defun eval. (e a)
  (cond
    ((atom e) (assoc. e a))
    ((atom (car e))
     (cond
       ((eq (car e) 'quote) (cadr e))
       ((eq (car e) 'atom)  (atom   (eval. (cadr e) a)))
       ((eq (car e) 'eq)    (eq     (eval. (cadr e) a)
                                    (eval. (caddr e) a)))
       ((eq (car e) 'car)   (car    (eval. (cadr e) a)))
       ((eq (car e) 'cdr)   (cdr    (eval. (cadr e) a)))
       ((eq (car e) 'cons)  (cons   (eval. (cadr e) a)
                                    (eval. (caddr e) a)))
       ((eq (car e) 'cond)  (evcon. (cdr e) a))
       ('t (eval. (cons (assoc. (car e) a)
                        (cdr e))
                  a))))
    ((eq (caar e) 'label)
     (eval. (cons (caddr e) (cdr e))
            (cons (list (cadar e) (car e)) a)))
    ((eq (caar e) 'lambda)
     (eval. (caddr e)
            (append. (pair (cadar e) (evlis. (cdr e) a))
                     a)))))

(defun evcon. (c a)
  (cond ((eval. (caar c) a)
         (eval. (cadar c) a))
        ('t (evcon. (cdr c) a))))

(defun evlis. (m a)
  (cond ((null m) '())
  ('t (cons (eval.  (car m) a)
            (evlis. (cdr m) a)))))

Copy "Surprise" from The Roots of Lisp

Copy "Surprise" from The Roots of Lisp

Signed-off-by: Pekka Enberg <add4fcd06328a394f0ad91feda7ee057316dc5ed@kernel.org>


;; common-impl-type.lisp - Implementation Support for Type Sys. Reflection, SBCL
;;------------------------------------------------------------------------------
;;
;; Copyright (c) 2014-2019 Sean Champ and others. All rights reserved.
;;
;; This program and the accompanying materials are made available under the
;; terms of the Eclipse Public License v1.0 which accompanies this distribution
;; and is available at http://www.eclipse.org/legal/epl-v10.html
;;
;; Contributors: Sean Champ - Initial API and implementation
;;
;;------------------------------------------------------------------------------

(in-package #:ltp/common/mop)

#+TBD
(defsignature defun type-defined-p (spec)
              (:parameters type-designator)
              (:values boolean &optional)
              (:documentation
               "Return a boolean value indicating whether the expression
SPEC denotes a type description, as per all named and derived type
definitions and class definitions in the null lexical environment"))

#+SBCL
(defun type-defined-p (spec)
  (declare (type type-designator)
           (values boolean &optional))
  ;; NB: Operates on the null lexical environment, intrinsically
  (cond
    ((classp spec)
     ;; TBD - Verify this onto applications, across implementations
     (class-finalized-p spec))
    (t
     ;; Initial Prototype, NB
     (let ((impl-ctype (sb-kernel:specifier-type spec)))
       (not (typep impl-ctype 'sb-kernel:unknown-type))))))

;; (type-defined-p (make-symbol "Frob"))
;; => NIL

;; TBD ... recursive processing for TYPE-DEFINED-P
;; (type-defined-p `(or ,(make-symbol "Frob") string))
;; =(??)=> T ;; Not ideal for applications, NB

Add an initial implementation of a naive TYPE-DEFINED-P (SBCL)


;; Common Lisp Script
;; Manoel Vilela

(defun pythagorean (a b c)
  (= (+ (* a a)
        (* b b))
     (* c c)))

(defun solution()
  (loop for a from 1 to 998 do
    (loop for b from a to 998 do
      (loop for c from b to 998
            when (and (= 1000 (+ a b c))
                      (pythagorean a b c))
                 do (return-from solution (* a b c))))))

(format t "~a~%" (solution))

Add solution for Problem009 written in Common Lisp


;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-

;;;;     Copyright (C) 2014  Varoun. P

;;;;     This program is free software: you can redistribute it and/or modify
;;;;     it under the terms of the GNU Affero General Public License as
;;;;     published by the Free Software Foundation, either version 3 of the
;;;;     License, or (at your option) any later version.

;;;;     This program is distributed in the hope that it will be useful,
;;;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;     GNU Affero General Public License for more details.

;;;;     You should have received a copy of the GNU Affero General Public License
;;;;     along with this program.  If not, see <http://www.gnu.org/licenses/>.

(in-package "CL-USER")

(asdf:defsystem :streamlets-tests
  :name "Streamlets Tests"
  :author "Varoun. P"
  :version "0.0.1"
  :licence "GNU AFFERO GENERAL PUBLIC LICENSE, Version 3"
  :maintainer '("Varoun. P")
  :description "Test code for Streamlets."
  :long-description "Test code for Streamlets."
  :defsystem-depends-on (:streamlets)
  :depends-on (:streamlets :nst)
  :serial t
  :components
    ((:module "packages"
	      :serial t
	      :pathname #p""
	      :components
	        ((:file "packages")))))

Create system definition file for streamlets tests.


;; Common Lisp Script
;; Manoel Vilela

(defun square (x)
  (* x x))

;; (1 2 3) => 1² + 2² + 3² => 14
(defun square-sum (list)
  (reduce #'+ (mapcar #'square
                      list)))

;; (1 2 3) => (1 + 2 + 3)² => 6² => 36
(defun sum-square (list)
  (square (reduce #'+ list)))

(defun solution(n)
  (let ((numbers (loop for x from 1 to n collect x)))
    (- (sum-square numbers)
       (square-sum numbers))))

(format t "~a~%" (solution 100))

Add solution for Problem006 written in Common Lisp


(defun range (n)
  (loop for x from 1 to n collect x))

(defun ilength (n)
  (length (write-to-string n)))

(defun solution()
  (loop
     for a in (range 9)
     for tries = (loop
                    for n in (range 21)
                    for x = (expt a n)
                    when (= (ilength x) n)
                      collect x)
     sum (length tries)))

(princ (solution))

Add solution for Problem063 written in Common Lisp


;; Some parts of tls require an implementation to perform
;; http, ldap, or other kind of network-based communication.
;; Defined here are classes and methods to be specialized to
;; provide such service
(in-package :cl-tls)

(defclass address ()
  ((host :initarg :host
	 :accessor host)
   (port :initarg :port
	 :accessor port)))

(defgeneric request-stream-to-address (address))

(defmethod request-stream-to-address ((addr address))
  (error "Oops, looks like you forgot to specialize cl-tls:get-stream-to-address"))

Add class and method for sockets

Add class and method for sockets


#!./interpreter.py

(set! testsFailed 0)
(set! testsSuccess 0)

(set! should
  (lambda (assertion msg)
    (if assertion
      (set! testsSuccess (+ testsSuccess 1))
      (begin
        (display (+ "Test failed : " msg))
        (set! testsFailed (+ testsFailed 1))
        )
      )
    )
  )

(set! shouldEqual
  (lambda (a b msg)
    (should (= a b) msg)
    )
  )

(set! testEnd
  (lambda ()
    (if (= testsFailed 0)
      (display "All tests ok")
      (display "Some tests failed")
      )
    )
  )

; Some simple sanity tests
(shouldEqual 4 (+ 1 3) "Adding two numbers")
(shouldEqual 4 (car (list 4 3 2)) "Taking the head of a list")
(shouldEqual (list 4 3 2) (cdr (list 4 3 2)) "Taking the head of a list")

(testEnd)

Add a simple test suite in lisp

Add a simple test suite in lisp


;; Common Lisp Script
;; Manoel Vilela

(defparameter *nodes* '((living-room (you are in the living-room.
                                      a wizard is snoring loudly on the couch.))
                        (garden (you are in a beatiful garden.
                                 there is a well in front of you.))
                        (attic (you are in the attic.
                                there os a goamt weçdomg torch in the corner.))))

(defparameter *edges* '((living-room (garden west door)
                                    (attic upstairs ladder))
                        (garden (living-room east door))
                        (attic (living-room downstairs ladder))))

(defparameter *objects* '(whiskey bucket frog chain))

(defparameter *objects-location* '((whiskey living-room)
                                   (bucket living-room)
                                   (chain garden)
                                   (frog garden)))

(defun describe-location (location nodes)
  "Sucint description of the localation provide
   @location -> symbol
   @nodes -> association list"
  (cadr (assoc location nodes)))

(defun describe-path (edge)
  "Sucint description of the path to achieve.
  @edge -> (neighbor direction way)"
  `(there is a, (caddr edge) going, (cadr edge) from here.))

(defun describe-paths (location edges)
  "General description of the possible edges on each location
   @location -> symbol
   @edges -> association list of `(node (neighbor direction way))"
  (apply #'append (mapcar #'describe-path (cdr (assoc location edges)))))q

;; func tests
(describe-path '(garden west door))
(describe-location 'living-room *nodes*)
(describe-paths 'living-room *edges*)

Add inital code about text game engine on cap5


;; $Id: example-1.lisp,v 1.1 2006-08-11 12:52:53 alemmens Exp $

(in-package :test-rucksack)

;; NOTE: This example doesn't run at the moment, because indexing doesn't
;; work correctly yet.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Indexing, class redefinitions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *example-1* #p"/tmp/rucksack/example-1/")

(defparameter *hackers* '("David" "Jim" "Peter" "Thomas"
                          "Arthur" "Jans" "Klaus" "James" "Martin"))

(with-rucksack (rucksack *example-1* :if-exists :supersede)
  (with-transaction ()

    ;; For classes that may change during program development, you should
    ;; wrap all class definitions in a WITH-RUCKSACK to make sure that
    ;; the corresponding schema definitions and indexes are updated correctly.
    ;; (This is only necessary if you already have a rucksack that contains
    ;; instances of the class that's being redefined, of course.)

    ;; Define a class hacker
    (defclass hacker ()
      ((id :initform (gensym "HACKER-")
           :reader hacker-id
           :index :symbol-index
           :unique t)
       (name :initform (elt *hackers* (random (length *hackers*)))
             :accessor name
             :index :case-insensitive-string-index)
       (age :initform (random 100) :accessor age))
      (:metaclass persistent-class))))

(defmethod print-object ((hacker hacker) stream)
  (print-unreadable-object (hacker stream :type t)
    (format stream "~S called ~S of age ~D"
            (hacker-id hacker)
            (name hacker)
            (age hacker))))

(defun example-1 ()
  (with-rucksack (rucksack *example-1*)
    ;; Fill the rucksack with some hackers.
    (with-transaction ()
      (loop repeat 1000
            do (make-instance 'hacker))
      #+nil
      (rucksack-map-slot rucksack 'hacker 'name
                         (lambda (hacker)
                           (print-object hacker *standard-output*)
                           (terpri))))))

(defun show-hackers ()
  (with-rucksack (rucksack *example-1*)
    (rucksack-map-class rucksack 'hacker
                        (lambda (hacker)
                          (print-object hacker *standard-output*)
                          (terpri)))))

Add indexing example (doesn't work yet).


(ql:quickload '(:arrow-macros :s-base64))
(use-package :arrow-macros)

(defvar *s1c1-hex* "49276d206b696c6c696e6720796f757220627261696e206c696b65206120706f69736f6e6f7573206d757368726f6f6d")
(defvar *s1c1-base64* "SSdtIGtpbGxpbmcgeW91ciBicmFpbiBsaWtlIGEgcG9pc29ub3VzIG11c2hyb29t")

(defun bytes->string (bytes)
  "Takes a sequence of integers represnting ascii chars and returns a string"
  (map 'string #'code-char bytes))

(defun maybe-pad-string (str)
  "Ensures a string is of even length by pre-padding with 0,
   so that it can be split into pairs"
  (if (/= 0 (mod (length str) 2))
      (concatenate 'string "0" str)
      str))

(defun string->pairs (str)
  "Splits a string into pairs of characters"
  (let ((str (maybe-pad-string str)))
    (loop for i upto (- (length str) 2) by 2
          collect (subseq str i (+ i 2)))))

(defun hexpairs->bytes (hexpairs)
  "Takes pairs of characters (as strings) and parses them as hexadecimal"
  (map 'vector #'(lambda (pair) (parse-integer pair :radix 16)) hexpairs))

(defun hex->bytes (hexstr)
  "Takes a hex string and parses it into character codes"
  (-> hexstr
    string->pairs
    hexpairs->bytes))

(defun hex->string (hexstr)
  "A convenience function to convert a hex string directly into a regular string"
  (-> hexstr
    hex->bytes
    bytes->string))

(defun bytes->base64 (bytes)
  "Converts a sequence of bytes to a string"
  (with-output-to-string (out)
    (s-base64:encode-base64-bytes bytes out)))

(defun base64->bytes (str)
  (with-input-from-string (in str)
    (s-base64:decode-base64-bytes in)))

(defun check-s1c1 ()
  (equalp *s1c1-base64* (-> *s1c1-hex* hex->bytes bytes->base64)))

Set 1, Challenge 1 in Lisp

Set 1, Challenge 1 in Lisp


(stefil:define-test-package :twitter-summary-card-tests
  (:use :cl :coleslaw
             :cl-ppcre))

(in-package :twitter-summary-card-tests)
;;;;
;; To run tests first eval the plugin code inside this package and then execute
;; (twitter-summary-card-test:run-package-tests)
;;;

(defvar *short-post*
    (make-instance 'post :title "hai" :text "very greetings" :format "html"))

(defvar *long-post*
    (make-instance 'post :title "What a Wonderful World"
                   :text "I see trees of green, red roses too.  I see them
bloom, for me and you.  And I think to myself, what a wonderful world.

I see skies of blue,
And clouds of white.
The bright blessed day,
The dark sacred night.
And I think to myself,
What a wonderful world.

The colors of the rainbow,
So pretty in the sky.
Are also on the faces,
Of people going by,
I see friends shaking hands.
Saying, \"How do you do?\"
They're really saying,
\"I love you\".

I hear babies cry,
I watch them grow,
They'll learn much more,
Than I'll ever know.
And I think to myself,
What a wonderful world.

Yes, I think to myself,
What a wonderful world. " :format "html"))

(deftest summary-card-sans-twitter-handle ()
  (let ((summary-card (summary-card *short-post* nil)))
    (is (null (scan "twitter:author" summary-card)))))

(deftest summary-card-with-twitter-handle ()
  (let ((summary-card (summary-card *short-post* "@PuercoPop")))
    (is (scan "twitter:author" summary-card))))

(deftest summary-card-trims-long-post ()
  (let ((summary-card (summary-card *long-post* nil)))
    ;; (scan "twitter:description\" content=\"(.*)\"" summary-card)
    summary-card))

Add tests as a PoC. Do not for merge.

Add tests as a PoC. Do not for merge.


;;;; strings.lisp

(in-package #:cryptopals)

(defconstant +ascii-hex+ '((#\0 . #x0) (#\1 . #x1) (#\2 . #x2) (#\3 . #x3)
                           (#\4 . #x4) (#\5 . #x5) (#\6 . #x6) (#\7 . #x7)
                           (#\8 . #x8) (#\9 . #x9) (#\a . #xa) (#\b . #xb)
                           (#\c . #xc) (#\d . #xd) (#\e . #xe) (#\f . #xf)))
(defun char->num (c)
  (let ((n (assoc c +ascii-hex+ :test #'char-equal)))
    (when (null n) (error "~a is not a hex character" c))
    (cdr n)))

(defun ascii-hex->bytes (hex)
  (let ((char-count (length hex)))
    (when (oddp char-count) (error "Odd-length hex string"))
    (let* ((byte-count (/ char-count 2))
           (bytes (make-array byte-count :element-type '(unsigned-byte 8))))
      (dotimes (i byte-count bytes)
        (setf (aref bytes i)
              (logior (ash (char->num (char hex (* i 2))) 4)
                      (char->num (char hex (1+ (* i 2))))))))))

Implement hex string to bytes

Implement hex string to bytes


;;;;; Transpiler: TRE to JavaScript
;;;;; Copyright (c) 2008-2010 Sven Klose <pixel@copei.de>

;; Make symbol in particular package.
(defun make-symbol (x &optional (pkg nil))
  (new __symbol x pkg))

;; Make package (which is just a symbol).
(defun make-package (x)
  (new __symbol x nil))

(defvar *keyword-package* (make-package ""))

(defun symbol-name (x)
  (if x
  	  x.n
	  ,*nil-symbol-name*))

(defun symbol-value (x) (when x x.v))
(defun symbol-function (x) (when x x.f))
(defun symbol-package (x) (when x x.p))

(dont-obfuscate is_a)

(defun symbolp (x)
  (is_a x "__symbol"))

;;;;; Transpiler: TRE to JavaScript
;;;;; Copyright (c) 2008-2010 Sven Klose <pixel@copei.de>

;; Make symbol in particular package.
(defun make-symbol (x &optional (pkg nil))
  (new __symbol x pkg))

;; Make package (which is just a symbol).
(defun make-package (x)
  (new __symbol x nil))

(defvar *keyword-package* (make-package ""))

(defun symbol-name (x)
  (if
    (eq t x)
      "T"
    x
  	  x.n
    ,*nil-symbol-name*))

(defun symbol-value (x) (when x x.v))
(defun symbol-function (x) (when x x.f))
(defun symbol-package (x) (when x x.p))

(dont-obfuscate is_a)

(defun symbolp (x)
  (is_a x "__symbol"))

SYMBOL-NAME: Return correct names for T and NIL which aren't real symbol objects.


(defmacro eval-when-test ((&rest specifers) &body body
                                              &enviroment environment)
  )

;; TBD:
;; - Test Specifiers - Syntax and Application Behaviors
;;   - Test Naming
;;   - Test Grouping
;;   - Test Evaluation Constraints
;;     - Code Evaluation Phase (onto ANSI CL vis. standard syntax and
;;       behaviors of CL:EVAL-WHEN)
;;     - Test Code Constraint onto Dependent Tests
;;       (when-success/when-fail)
;;   - Test Component Dependencies
;;     - "Test Harness" Intrgration onto ASDF - Dependency Management?
;; - Test Definition, Eval, and Reporting - Procedural Model
;;   - This topic representing the "Bread and Butter" of the "Test
;;     Harness," in applications
;;   - Test Definition
;;     - Inline Test Definition
;;     - Test Defintion in External File
;;     - Test Definition in Runtime Application Code Generation
;;     - "Test Harness" Intrgration onto ASDF - Test Declaration in
;;       System Definition
;;   - Test Orchestration
;;     - "Test Harness" Intrgration onto ASDF - ASDF:TEST-OP
;;     - Test Activation
;;     - Test Monitoring
;;   - Test Reporting
;;     - Report Generation
;;     - Report Publishing

Add prototype from 15 November 2017 - [SYCAMOPE] wkspace


(declare
 (newline (ascii "\n"))
 (double (function integer integer))
 (triple (function integer integer))
 (do-42 (function integer
         (func-pointer integer integer)))
 (main (function byte)))

(define double (x)
 (declare)
 (return (* x 2)))

(define triple (x)
 (declare)
 (return (* x 3)))

(define do-42 (func)
 (declare)
 (return (func 42)))

(define main ()
 (declare)
 (block
  (@print-int (do-42 double))
  (@print-string newline)
  (@print-int (do-42 triple))
  (@print-string newline)))

Add a sample for function pointers

Add a sample for function pointers


(in-package :common-lisp-user)

(defpackage :app
  (:use :clim :clim-lisp)
  (:export #:app-main))

(in-package :app)

(define-application-frame superapp ()
  ()
  (:pointer-documentation t)
  (:panes
    (app :application :display-time t :height 300 :width 600)
    (int :interactor :height 200 :width 600))
  (:layouts
    (default (vertically () app int))))

(defun app-main ()
  (run-frame-top-level (make-application-frame 'superapp)))

(define-superapp-command (com-quit :name t) ()
  (frame-exit *application-frame*))

(define-presentation-type name-of-month ()
  :inherit-from 'string)

(define-presentation-type day-of-month ()
  :inherit-from 'integer)

(define-superapp-command (com-out :name t) ()
  (with-output-as-presentation (t "The third month" 'name-of-month)
    (format t "March~%"))
  (with-output-as-presentation (t 15 'day-of-month)
    (format t "fifteen~%")))

(define-superapp-command (com-get-date :name t)
    ((name 'name-of-month) (date 'day-of-month))
  (format (frame-standard-input *application-frame*)
	  "the ~a of ~a~%" date name))

Include example of use of presentation types.


;; Common Lisp Script
;; Manoel Vilela

(defun fib (n)
  (labels ((tail-fib (n a b)
             (if (= n 0)
                 a
                 (tail-fib (1- n)
                           b
                           (+ a b)))))
    (tail-fib n 0 1)))

(defun solution ()
  (format t "~a~%" (loop for x from 0
                          for fib-x = (fib x)
                          while (< fib-x 4000000)
                          when (evenp fib-x) sum fib-x)))

(solution)

Add solution for Problem002 written in Common Lisp


;; Common Lisp Script
;; Manoel Vilela

(defun reverse-digits (n)
  (labels ((next (n v)
             (if (zerop n)
                 v
                 (multiple-value-bind (q r)
                     (truncate n 10)
                   (next q (+ (* v 10) r))))))
    (next n 0)))

(defun palindromep (n)
  (= n (reverse-digits n)))

(defun solution()
  (loop for x from 100 to 999
        maximize (loop for y from 100 to 999
                       for p = (* x y)
                       when (palindromep p) maximize p)))

(format t "~a ~%"(solution))

Add solution for Problem004 written in Common Lisp


(declare
 (jagged (struct (a integer)
                 (b byte)))

 (takes-jagged (function byte jagged))
 (requires-right-alignment (function integer integer))
 (main (function byte)))

(define takes-jagged (jagged)
 (declare)
 (block))

(define requires-right-alignment (a)
 (declare)
 (block
  (return a)))

(define main ()
 (declare (jag jagged))
 (block
  (takes-jagged jag)
  (requires-right-alignment 5)))

Add sample for jagged structs

Add sample for jagged structs

I had a vague idea that jagged struct parameters might pose an issue, this
test is just to confirm that.


(defun function1 (state environment)
  (if (>= state 40)
    (cons 0 0)
    (cons (+ 1 state) (/ state 10))))

(cons 0 function1)

Add a simple LambdaMan program that moves 10 squares


;;;; unit-tests.lisp
;;;; Author: Elliot Penson

(in-package :knight-owl)

(ql:quickload "fiveam")
(use-package :fiveam)

(def-suite knight-owl-suite)
(in-suite knight-owl-suite)

(test file->index
  (is (= (file->index #\a) 0))
  (is (= (file->index #\b) 1))
  (is (= (file->index #\c) 2))
  (is (= (file->index #\d) 3))
  (is (= (file->index #\e) 4))
  (is (= (file->index #\f) 5))
  (is (= (file->index #\g) 6))
  (is (= (file->index #\h) 7)))

(test rank->index
  (is (= (rank->index #\1) 7))
  (is (= (rank->index #\2) 6))
  (is (= (rank->index #\3) 5))
  (is (= (rank->index #\4) 4))
  (is (= (rank->index #\5) 3))
  (is (= (rank->index #\6) 2))
  (is (= (rank->index #\7) 1))
  (is (= (rank->index #\8) 0)))

(test enclosed-by
  (is (equal (enclosed-by 1 5)
             '(2 3 4)))
  (is (equal (enclosed-by 0 5)
             '(1 2 3 4)))
  (is (equal (enclosed-by -5 5)
             '(-4 -3 -2 -1 0 1 2 3 4)))
  (is (equal (enclosed-by -5 0)
             '(-4 -3 -2 -1)))
  (is (equalp (enclosed-by -5 -1)
              '(-4 -3 -2)))
  (is (equalp (enclosed-by 5 1)
              '(4 3 2)))
  (is (equalp (enclosed-by 5 0)
              '(4 3 2 1)))
  (is (equalp (enclosed-by 5 -5)
              '(4 3 2 1 0 -1 -2 -3 -4)))
  (is (equalp (enclosed-by 0 -5)
              '(-1 -2 -3 -4)))
  (is (equalp (enclosed-by -1 -5)
              '(-2 -3 -4))))

Add unit tests for three board functions


;;;; © 2016-2020 Marco Heisig         - license: GNU AGPLv3 -*- coding: utf-8 -*-

(in-package #:petalisp.ir)

;;; In this file, we partition each kernel into tasks.  We do this by first
;;; computing the optimal dimensions of a task, and then cut the domain
;;; into tasks that are at most as large as that.

(defgeneric optimal-task-dimensions (kernel processor backend))

;;; The default method for computing the optimal dimensions of a task is to
;;; chose a hypercube such that all loads and stores fit into that task's
;;; share of the caches.
;;;
;;; TODO: More sophisticated partitioning schemes are conceivable.  This is
;;; just a simple version to get things going.
(defmethod optimal-task-dimensions (kernel processor backend)
  (let* ((rank (shape-rank (kernel-iteration-space kernel)))
         (size (if (zerop rank)
                   (return-from optimal-task-dimensions '())
                   (shape-size (kernel-iteration-space kernel))))
         (machine (backend-machine backend))
         (main-memory (machine-main-memory machine))
         (cache-size
           (loop for memory = (processor-memory processor)
                   then (memory-parent memory)
                 until (or (null memory)
                           (eq memory main-memory))
                 sum (floor (memory-size memory)
                            (length
                             (memory-processors memory)))))
         (bytes-per-element
           (let ((bits 0.0))
             (flet ((count-bits (buffer)
                      (incf bits
                            ;; In case the size of the buffer is smaller
                            ;; than the size of the kernel iteration space,
                            ;; we scale down the number of transferred
                            ;; bytes accordingly.
                            (* (float (shape-size (buffer-shape buffer)))
                               (/ (float size))
                               (float
                                (petalisp.type-inference:ntype-size
                                 (buffer-ntype buffer)))))))
               (map-kernel-inputs #'count-bits kernel)
               (map-kernel-outputs #'count-bits kernel))
             ;; Ensure that the bytes per elements can never be zero.
             (min 1.0 (/ bits 8)))))
    (make-list
     rank
     :initial-element
     (floor
      (expt (/ cache-size bytes-per-element)
            (/ rank))))))

Add a function for computing the optimal dimensions of a task.


(defpackage :next.tests
  (:use :common-lisp
   :next
        :prove))

(in-package :next.tests)

(plan nil)

(defvar test-ring1 (make-instance 'next::ring))

(loop for i from 1 to 1000
      do (next::ring-insert test-ring1 (make-string i :initial-element #/a)))

(subtest "Add 1000 items, test head-index, item-count, car of recent-list length."
  (is 0
      (next::head-index test-ring1))
  (is 1000
      (next::item-count test-ring1))
  (is 1000
      (length (car (next::ring-recent-list next.tests::test-ring1)))))

(loop for i from 1 to 5
      do (next::ring-insert test-ring1 (make-string i :initial-element #/b)))

(subtest "Add 5 more items, test head-index again, and item-count again, then car recent-list."
  (is 5
      (next::head-index test-ring1))
  (is 1000
      (next::item-count test-ring1))
  (is "bbbbb"
      (car (next::ring-recent-list test-ring1))))

(finalize)

Add some tests for ring class.

Add some tests for ring class.


(in-package :cl-user)

(ql:quickload :arrow-macros)
(defpackage #:lisp-interface
  (:use #:cl #:cl-neovim #:arrow-macros)
  (:shadowing-import-from #:cl #:defun #:eval))
(in-package :lisp-interface)

(nvim:defcommand/s lisp (&rest form)
  (declare (opts nargs))
  (let ((output (with-output-to-string (*standard-output*)
                  (->> form  ; == '("(+" "1" "2)")
                    (format nil "~{~A~^ ~}")
                    read-from-string
                    eval))))
    (nvim:command (format nil "echo '~A'" output))))

(in-package :cl-user)

Add :Lisp command (lisp equivalent of :python)


;;;; chess.lisp
;;;; Author: Elliot Penson

(in-package :knight-owl)

(defconstant +number-of-files+ 8)

(defconstant +number-of-ranks+ 8)

(defconstant +initial-board+
  #2A((b-r b-n b-b b-q b-k b-b b-n b-r)
      (b-p b-p b-p b-p b-p b-p b-p b-p)
      (nil nil nil nil nil nil nil nil)
      (nil nil nil nil nil nil nil nil)
      (nil nil nil nil nil nil nil nil)
      (nil nil nil nil nil nil nil nil)
      (w-p w-p w-p w-p w-p w-p w-p w-p)
      (w-r w-n w-b w-q w-k w-b w-n w-r))
  "Two-dimensional array of piece symbols in the form [bw]-[prnbqk]")

(defun new-board ()
  "Evaluates to a fresh 2D array with initial the chess position"
  (let ((board (make-array (list +number-of-files+
                                 +number-of-ranks+))))
    (dotimes (index (array-total-size board))
      (setf (row-major-aref board index)
            (row-major-aref +initial-board+ index)))
    board))

(defun get-square (board file rank)
  "Accesses a chess board x/y location"
  (aref board rank file))

(defun (setf get-square) (value board file rank)
  "Sets a chess board x/y location"
  (setf (aref board rank file) value))

Include basic board representation and interaction


(in-package :asdf)

(defsystem "lispos"
  :description "Lisp operating system."
  :version "0"
  :author "Henry Harrington <henry.harrington@gmail.com>"
  :licence "None"
  :components ((:file "build-unicode")
               (:file "lap")
               (:file "lap-x86" :depends-on ("lap"))
               (:file "genesis/genesis")
               (:file "genesis/read" :depends-on ("genesis/genesis"))
               (:file "genesis/eval" :depends-on ("genesis/genesis"))
               (:file "genesis/dump" :depends-on ("genesis/genesis"
                                                  "genesis/eval"
                                                  "lap-x86"
                                                  "build-unicode"))))

Add an ASDF system definition!

Add an ASDF system definition!


(defun qsort (l)
  (print l)
  (cond
   ((null l) nil)
   ((= (length l) 1) l)
   (T
    (setq l1
          (qsort
           (remove-if-not
            (lambda (x) (> (first l) x))
            (rest l))))
    (setq l2
          (qsort
           (remove-if
            (lambda (x) (> (first l) x))
            (rest l))))
    (append
     (append
      l1
      (list (first l)))
     l2))))

(print (qsort '(3 4 2 5 1)))

Add a broken lisp quicksort

Add a broken lisp quicksort


;; Common Lisp Script
;; Manoel Vilela

;; higher-order function sigma-sum
;; func must be a lambda(x) expression
(defun sigma-sum (func a b)
  (if (> a b)
      0
      (+ (funcall func a)
         (sigma-sum func (1+ a) b))))

(defun square (x)
  (* x x))

(sigma-sum #'(lambda(x) (/ 1 x)) 1 10)
(sigma-sum #'(lambda(x) (- x)) 1 10)

Add material about lambda expressions

Add material about lambda expressions


;; Common Lisp Script
;; Manoel Vilela

(format t "~a~%" (mod (+ 1 (* 28433 (expt 2 7830457)))
                      (expt 10 10)))

Add solution for Problem097 written in Common Lisp

Seems SBCL make some internals optimizations for A^B mod C. The whole
evaluation takes only 0.08s.


;; Common Lisp Script
;; Manoel Vilela

(defun factors (n)
  "Return a list of '(prime factor) for n
   (factors 100) => ((2 2) (5 2))
  "
  (loop for x from 2
        while (> n 1)
        when (= 0 (mod n x))
          collect (loop for c from 0
                        while (= 0 (mod n x))
                        do (setq n (/ n x))
                        finally (return (list x c)))))

(defun solution ()
  (loop for (p f) in (factors 600851475143) maximize p))

(format t "~a ~%"(solution))

Add solution for Problem003 written in Common Lisp


(in-package :cl-user)
(defpackage :gaussian-integers
  (:use :cl))

(in-package :gaussian-integers)

(defun print-g-int (g-int)
  (format nil "(~A+~A)i" (car g-int) (cadr g-int)))

(defun add-g-ints (&rest g-ints)
  (funcall #'apply-g-int-operation #'+ g-ints))

(defun subtract-g-ints (&rest g-ints)
  (funcall #'apply-g-int-operation #'- g-ints))

(defun apply-g-int-operation (fn g-ints)
  (reduce #'(lambda (result item)
              (list (funcall fn (first result) (first item))
                    (funcall fn (second result) (second item))))
          (cdr g-ints) :initial-value (car g-ints)))

Add rudimentary gaussina integer support


(import base (clock))
(import string (#s sub))

(defmacro do (&statements)
  (letrec [(name (gensym))
           (unfold
             (lambda (stmt)
               (let* [(hd (car stmt))
                      (stmt (cdr stmt))]
                 (cond
                   [(eq? hd 'for)
                    (let* [(var (nth stmt 1))
                           (sep (nth stmt 2))
                           (lis (nth stmt 3))
                           (rest (cdddr stmt))
                           (var_ (gensym (symbol->string var)))
                           (lis_ (gensym (symbol->string lis)))]
                      (cond
                        [(eq? sep 'in)
                         `(for ,var_ 1 (# ,lis) 1
                            (let [(,lis_ ,lis)
                                  (,var (nth ,lis_ ,var_))]
                            ,(unfold rest)))]
                        [(eq? sep 'over)
                         `(let [(,lis_ ,lis)]
                            (for ,var_ 1 (#s ,lis) 1
                              (let [(,var (sub ,lis_ ,var_ ,var_))]
                                ,(unfold rest))))]
                        [(and (eq? sep 'from)
                              (eq? (nth stmt 4) 'to))
                         (let [(start (nth stmt 3))
                               (end (nth stmt 5))]
                          `(for ,var ,start ,end 1
                            ,(unfold (slice stmt 6))))]))]
                   [(eq? hd 'when)
                    (let* [(cond_ (car stmt))
                           (rest  (cdr stmt))]
                      `(if ,cond_
                         ,(unfold rest)
                         (push-cdr! ,name '())))]
                   [(eq? hd 'do)
                    (let* [(expr_ (car stmt))
                           (rest (cdr stmt))]
                      `(progn
                         ,expr_
                         ,(unfold rest)))]
                   [(eq? hd 'yield)
                    (let* [(val_ (car stmt))
                           (rest (cdr stmt))]
                      `(progn
                         (push-cdr! ,name ,val_)
                         ,(unfold rest)))]
                   [true 'nil ]))))]
    `(let [(,name '())]
       ,(unfold statements)
       (prune ,name))))

Add list comprehensions to the standard library


#!./interpreter.py
(require "unittest.lisp")

; Some simple sanity tests
(shouldEqual 4 (+ 1 3) "Adding two numbers")
(shouldEqual 4 (car (list 4 3 2)) "Taking the head of a list")
(shouldEqual (list 3 2) (cdr (list 4 3 2)) "Taking the tail of a list")

; Some lambda test
(set! increment (lambda (x) (+ x 1)))
(shouldEqual (increment 3) 4 "Simple incrementer lambda")

(testEnd)

Add a regression test script

Add a regression test script


;; Common Lisp Script
;; Manoel Vilela

(flet ((foo (when funcall)
        (when (< 3 when)
          (funcall funcall)) when))
      (loop :named funcall :for funcall :from 1 :collect
            (foo funcall (lambda () (loop-finish)))))

Add a cool troll code about multiple namespaces


;; Common Lisp version
;; Manoel Vilela

(defun div (x d)
  (= (mod x d) 0))

(defun special-sum (n)
  (reduce '+ (loop for x from 1 to n when (or (div x 5) (div x 3)) collect x)))

(format t "~d" (special-sum 1000))

Add Common Lisp solution for Problem001

Add Common Lisp solution for Problem001

Some weird here... the answer is wrong, LOL. But the code
is so simple that I don't understand... The solution return a value
with error of +100.


;; Common Lisp Script
;; Manoel Vilela

(defun sum-digits (number &optional (base 10))
  (loop for n = number then q
        for (q r) = (multiple-value-list (truncate n base))
        sum r until (zerop q)))

(defun solution ()
  (loop for a from 1 to 100
        maximize (loop for b from 1 to 100
                       maximize (sum-digits (expt a b)))))

(format t "~a~%" (solution))

Add solution for Problem056 written in Common Lisp


;; Common Lisp Script
;; Manoel Vilela

(defun primep (n)
  (let ((divisors (loop for x from 2 to (floor (1+ (sqrt n)))
                        collect x)))
    (loop for d in divisors
          never (and (= (mod n d) 0)
                     (not (= n d))))))

(defun solution (limit)
  (loop for x from 2
        for prime? = (primep x)
        count prime? into primes
        while (< x limit)
        when prime? sum x))

(format t "~a~%" (solution 2000000))

Add solution for Problem010 written in Common Lisp


#!/usr/bin/sbcl
;; Common Lisp Script
;; Manoel Vilela

(defun my-command-line ()
  (or
   #+SBCL sb-ext:*posix-argv*
   #+CLISP *args*
   #+LISPWORKS system:*line-arguments-list*
   #+CMU extensions:*command-line-words*
   nil))

(format t "~&~S~&" (my-command-line))

Add tricks about dealing with command line args (argv)


;After setting up quicklisp, run this file in clisp to run the test suite.
(load "~/.clisprc.lisp")
(ql:quickload "magician")
(ql:quickload "magician-test")

Add a lisp script that runs the tests

Add a lisp script that runs the tests


(require :cl-ppcre)
(require :anaphora)
(use-package :anaphora)

;; Encode a js symbol, graciously stolen from from Parenscript
(let ((cache (make-hash-table :test 'equal)))
  (defun encode-js-identifier (identifier)
    "Given a string, produces to a valid JavaScript identifier by
following transformation heuristics case conversion. For example,
paren-script becomes parenScript, *some-global* becomes SOMEGLOBAL."
    (or (gethash identifier cache)
        (setf (gethash identifier cache)
              (cond ((some (lambda (c) (find c "-*+!?#@%/=:<>^")) identifier)
                     (let ((lowercase t)
                           (all-uppercase nil))
                       (when (and (not (string= identifier "[]")) ;; HACK
                                  (find-if (lambda (x) (find x '(#\. #\[ #\]))) identifier))
                         (warn "Symbol ~A contains one of '.[]' - this compound naming convention is no longer supported by Parenscript!"
                               identifier))
                       (acond ((nth-value 1 (cl-ppcre:scan-to-strings "[\\*|\\+](.+)[\\*|\\+](.*)"
                                                                      identifier :sharedp t))
                               (setf all-uppercase t
                                     identifier (concatenate 'string (aref it 0) (aref it 1))))
                              ((and (> (length identifier) 1)
                                    (or (eql (char identifier 0) #\+)
                                        (eql (char identifier 0) #\*)))
                               (setf lowercase nil
                                     identifier (subseq identifier 1))))
                       (with-output-to-string (acc)
                         (loop for c across identifier
                            do (acond ((eql c #\-)
                                       (setf lowercase (not lowercase)))
                                      ((position c "!?#@%+*/=:<>^")
                                       (write-sequence (aref #("bang" "what" "hash" "at" "percent"
                                                               "plus" "star" "slash" "equals" "colon"
                                                               "lessthan" "greaterthan" "caret")
                                                             it)
                                                       acc))
                                      (t (write-char (cond ((and lowercase
                                                                 (not all-uppercase))
                                                            (char-downcase c))
                                                           (t (char-upcase c)))
                                                     acc)
                                         (setf lowercase t)))))))
                    ((every #'upper-case-p (remove-if-not #'alpha-char-p identifier))
                     (string-downcase identifier))
                    ((every #'lower-case-p (remove-if-not #'alpha-char-p identifier))
                     (string-upcase identifier))
                    (t identifier))))))

Add Parenscript symbol encoding routine.


;; Common Lisp Script
;; Manoel Vilela

#| A heuristic method to calculate the
   square root of a number x based on the
   Hero of Alexandria's alogrithm.
 |#

(defparameter *error-limit* 0.001)

(defparameter *tests* '((square-root 2)
                        (square-root 12)
                        (square-root 25)
                        (square-root 144)
                        (square-root 165465)
                        ))

(defun square (x)
  (* x x))

(defun average (x y)
  (/ (+ x y) 2))

(defun improve (guess x)
  (average guess (/ x guess)))

(defun good-enough? (guess x)
  (< (abs (- (square guess) x))
     *error-limit*))

(defun try (guess x)
  (if (good-enough? guess x)
      guess
      (try (improve guess x) x)))

(defun square-root (x) (float (try 1 x)))

(defun call-test (test)
  (let ((output (eval test)))
       (format t "~s -> ~f ~%" test output)
       output))

(defun eval-test (test fn)
   (let ((x (cadr test)))
       (if (< (abs (- (call-test test) (funcall fn x)))
              *error-limit*)
           :nice
           :fail)))

(defun run-tests (tests)
  (format t "Running tests with limit ~f ~%" *error-limit*)
  (let* ((results (loop for x in *tests* collect (eval-test x #'sqrt)))
         (total (length results))
         (pass (count :nice results)))
      (format t "Tests avalied [pass/total]: ~d/~d ~%" pass total)))

(run-tests *tests*)

Add heuristic square-root algorithm in Common Lisp

The algoritm is based on MIT 6.0001 lectures about Lisp
on course Structures and Interpretations at '86.


;; Common Lisp Script
;; Manoel Vilela

(defun integer-to-list (x)
  (if (< x 10)
      (cons x nil)
      (cons (mod x 10)
            (integer-to-list (floor (/ x 10))))))

(defun sum (the-list)
  (reduce '+ the-list))

(defun fat (x)
  (if (<= x 2)
      x
      (* x (fat (1- x)))))

(defun solution ()
  (sum (integer-to-list (fat 100))))

(princ (solution))

[P020] Add CommonLisp solution based at 16 solution


(import compiler/pass ())
(import compiler/nodes ())

(import lua/basic (set-idx!))

(defun get-lookup (lookup key)
  :hidden
  (with (len (n lookup))
    (loop [(i 2)]
      [(> i len)
       (with (sub (list (fix-symbol `struct-literal)))
         (push-cdr! lookup key)
         (push-cdr! lookup sub)
         sub)]
      (if (eq? (nth lookup i) key)
        (nth lookup (succ i))
        (recur (+ i 2))))))

(defpass fold-defgeneric (state nodes)
  "Merges put!s into their corresponding method."
  :cat '("opt")
  (let [(methods {})
        (i 1)]
    (while (< i (n nodes))
      (with (node (nth nodes i))
        ;; Match against (define X ... (setmetatable (struct-literal :lookup Y)))
        (when (and (list? node) (builtin? (car node) :define)
                   (with (def (last node))
                     (and (list? def) (= (symbol->var (car def)) (symbol->var `setmetatable))
                          (with (tbl (cadr def))
                            (and (list? tbl) (= (symbol->var (car tbl)) (builtin :struct-literal))
                                 (eq? (cadr tbl) :lookup))))))

          (.<! methods (.> node :def-var) (cadr (last node))))

        (cond
          ;; Match against (put! X (:lookup Y*) Z)
          [(and (list? node) (symbol? (car node))
                (= (.> (car node) :var :full-name) "core/type/put!") ;; HACK HACK HACK
                (.> methods (symbol->var (cadr node))))
           (let [(lookup (caddr (.> methods (symbol->var (cadr node)))))
                 (entries (caddr node))
                 (def (cadddr node))]

             (for i 3 (pred (n entries)) 1
               (set! lookup (get-lookup lookup (nth entries i))))

             (push-cdr! lookup (last entries))
             (push-cdr! lookup def)
             (remove-nth! nodes i))]

          ;; Match against (set-idx! X :default Y)
          [(and (list? node) (= (n node) 4)
                (= (symbol->var (car node)) (symbol->var `set-idx!))
                (.> methods (symbol->var (nth node 2)))
                (eq? (nth node 3) :default))
           (with (method (.> methods (symbol->var (nth node 2))))
             (push-cdr! method (nth node 3))
             (push-cdr! method (nth node 4)))
           (remove-nth! nodes i)]

          [else
           (inc! i)])))))

,(add-pass! fold-defgeneric)

Add a small plugin to fold defmethod/defdefaults

This helps keep the definition in one place, and so the optimiser can
strip the definition if needed.


(require :amino)

(in-package :robray)

(sb-posix:setenv "ROS_PACKAGE_PATH" "/opt/ros/indigo/share/" 1)

(setq *scene-graph* (load-scene-file "package://baxter_description/urdf/baxter.urdf"))

(defparameter *sub-scene-graph* (scene-graph-chain *scene-graph* nil "right_w2"))

(win-set-scene-graph *scene-graph*)

(win-run)

;(defparameter *e0* (tf (vec 0.000000	1.000000	0.000000	0.000000	0.800000	-0.250000	0.305100)))

(defparameter *e1* (tf* (quaternion* 0.000000 0.707107 0.707107 -0.000000)
                        (vec3* 0.600000 0.000000 0.500000)))

(defparameter *q0* (scene-graph-center-map *scene-graph*))

(defparameter *q0*
  (alist-configuration-map
   '(("right_s0" . 0.664700d0) ("right_s1" . -0.666419d0)
     ("right_e0" . 0.249159d0) ("right_e1" . 1.079791d0)
     ("right_w0" . -0.211153d0) ("right_w1" . 1.180571d0) ("right_w2" . 0.116756d0))))

(win-set-scene-graph *scene-graph* :configuration-map *q0*)

(defparameter *ksol-opts*
  (ksol-opt :dt .1d0
            :gain-angle 5d0
            :gain-trans 5d0))

(defparameter *plan*
  (cartesian-path *sub-scene-graph* *q0* *e1*
                  :ksol-opts *ksol-opts*))

(win-display-motion-plan *plan*)

Add path IK lisp demo

Add path IK lisp demo


; Using only operators introduced in this chapter define a function
; that takes a list as an argument and returns true if one of its
; elements is a list

(defun has_list_recursive (lst)
  (if (null lst)
      nil
    (if (listp (car lst))
        t
      (has_list_recursive (cdr lst))))
)

(has_list_recursive '(a b c))
(has_list_recursive '(a (b c)))
(has_list_recursive '(a b (c)))
(has_list_recursive '(a (b) c))
(has_list_recursive '((a) b c))

(defun has_list_iterative (lst)
  (if (null lst)
      nil
    lst
    ))

(defun has_list_iterative (lst)
  (if (null lst)
      nil
    (dolist (obj lst)
      (if (listp obj)
          (setf islist t)
        ))
    islist))

(has_list_iterative '(a b c))
(has_list_iterative '(a (b c)))
(has_list_iterative '(a b (c)))
(has_list_iterative '(a (b) c))
(has_list_iterative '((a) b c))

Add new lisp example problem file. Save updates to cashflow and make-cscope.sh