Commit 72c642b4 authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Merged.

parents aaee6718 c50aa1bd
......@@ -38,7 +38,8 @@
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.ARITHMETIC.PRIMES"
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
(:export "STR-DECODE" "STR-ENCODE" "PRINT-FACTORIZATION" "FACTORIZE"
(:export "STR-DECODE" "STR-ENCODE" "PRINT-FACTORIZATION"
"FACTORIZE" "DIVISORS"
"COMPUTE-PRIMES-TO")
(:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY" "WHILE")
(:documentation
......@@ -227,4 +228,35 @@ RETURN: A string decoding the integer NUM factorized with the PRIMES.
primes (subseq (factorize-vector num primes) 1))))
(defun exponent-combinations (exponents)
(if (null exponents)
'(())
(let ((e (first exponents))
(c (exponent-combinations (rest exponents))))
(loop
:for i :to e
:append (mapcar (lambda (r) (cons i r)) c)))))
(defun divisors (n)
"
RETURN: a list of divisors of N from 1 to N.
"
(let* ((prime-factors (rest (factorize n)))
(exponents (mapcar (lambda (term)
(if (atom term)
1
(third term)))
prime-factors))
(primes (mapcar (lambda (term)
(if (atom term)
term
(second term)))
prime-factors)))
(mapcar (lambda (exponents)
(reduce (function *) (mapcar (function expt) primes exponents)
:initial-value 1))
(exponent-combinations exponents))))
;;;; THE END ;;;;
......@@ -33,24 +33,13 @@
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.A-STAR"
(:use "COMMON-LISP")
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
(:export "+INFINITY+" "FIND-PATH")
(:documentation "The A* algorithm."))
(in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.A-STAR")
(defmacro with-functions ((&rest fnames) &body body)
`(flet ,(mapcar (lambda (fname)
(if (listp fname)
(destructuring-bind (name &rest parameters) fname
`(,name ,parameters (funcall ,name ,@parameters)))
`(,fname (&rest arguments) (apply ,fname arguments))))
fnames)
(declare (inline ,@(mapcar (lambda (fname) (if (listp fname) (first fname) fname)) fnames)))
,@body))
(defconstant +infinity+ most-positive-long-float)
(defun find-path (successors previous set-previous cost set-cost estimate-distance goalp
......
......@@ -79,7 +79,7 @@
"PRINT-NOT-READABLE-OBJECT")
(:export
;; 3 - EVALUATION AND COMPILATION
"WITH-GENSYMS" "WSIOSBP" "PROGN-CONCAT"
"WITH-FUNCTIONS" "WITH-GENSYMS" "WSIOSBP" "PROGN-CONCAT"
"CURRY" "COMPOSE" "COMPOSE-AND-CALL"
"/NTH-ARG" "/APPLY"
"DEFINE-IF-UNDEFINED" "INCLUDE-FILE" "FUNCTIONAL-PIPE"
......@@ -179,6 +179,17 @@ The results of THUNK are ignored.
(defmacro chrono (&body body)
`(chrono* (lambda () ,@body)))
(defmacro with-functions ((&rest fnames) &body body)
`(flet ,(mapcar (lambda (fname)
(if (listp fname)
(destructuring-bind (name &rest parameters) fname
`(,name ,parameters (funcall ,name ,@parameters)))
`(,fname (&rest arguments) (apply ,fname arguments))))
fnames)
(declare (inline ,@(mapcar (lambda (fname) (if (listp fname) (first fname) fname)) fnames)))
,@body))
#-:with-debug-gensym
(defmacro with-gensyms (syms &body body)
"
......
......@@ -12,6 +12,7 @@
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2015-10-22 <PJB> Added &quot; and &apo; Added *PRE* for MELT-ENTITIES.
;;;; 2010-10-16 <PJB> Renamed HTML-ENTITIES.
;;;; Added handling of numerical &#...; and &#x...; entities.
;;;; 2003-11-14 <PJB> Created.
......@@ -50,7 +51,9 @@
"Aacute" "Agrave" "iquest" "frac34" "frac12" "frac14" "raquo" "ordm" "sup1"
"cedil" "middot" "para" "micro" "acute" "sup3" "sup2" "plusmn" "deg" "macr"
"reg" "shy" "not" "laquo" "ordf" "copy" "uml" "sect" "brvbar" "yen" "curren"
"pound" "cent" "iexcl" "nbsp" "MELT-ENTITIES")
"pound" "cent" "iexcl" "nbsp"
"lt" "gt" "amp" "quot" "apo"
"MELT-ENTITIES" "*PRE*")
(:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ARRAY" "DISPLACED-VECTOR")
(:import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STRING" "STRING-REPLACE")
(:documentation
......@@ -63,7 +66,7 @@ License:
AGPL3
Copyright Pascal J. Bourguignon 2003 - 2012
Copyright Pascal J. Bourguignon 2003 - 2015
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
......@@ -92,12 +95,14 @@ License:
to a string containing their corresponding characters.")
(defvar *pre* nil
"When true, MELT-ENTITIES will keep spaces and newlines.")
(defun melt-entities (text)
"
RETURN: A string with any HTML ISO-Latin-1 entity occurence replaced by
the corresponding character.
BUG: We don't manage the encodings, assuming that ISO-Latin-1 is active.
BUG: We don't manage the encodings, assuming CODE-CHAR gives ISO-Latin-1.
"
(with-output-to-string (*standard-output*)
(loop
......@@ -113,12 +118,16 @@ BUG: We don't manage the encodings, assuming that ISO-Latin-1 is active.
((#\&)
(setf state :ampersand))
((#\newline #\space)
(princ " ")
(if *pre*
(princ ch)
(princ " "))
(setf state :space))
(otherwise
(princ ch))))
((:space) (case ch
((#\newline #\space))
((#\newline #\space)
(when *pre*
(princ ch)))
((#\&)
(setf state :ampersand))
(otherwise
......@@ -187,39 +196,11 @@ BUG: We don't manage the encodings, assuming that ISO-Latin-1 is active.
(format t "&#x~A~C" buffer ch)
(setf state :normal)))))
:finally (case state
((:normal))
(otherwise (princ buffer)))))
((:normal :space))
(otherwise (princ buffer))))))
;; (let ((chunks (list string)))
;; (DOLIST (SUBSTITUTION *ENTITIES*
;; (apply (function concatenate) 'string chunks))
;; (when (some (lambda (chunk) (search (car substitution) chunk
;; :test (function string=))) chunks)
;; (setf chunks
;; (mapcan
;; (lambda (chunk)
;; (do* ((start 0 (+ pos (length (car substitution))))
;; (pos (search (car substitution) chunk
;; :start2 start
;; :test (function string=))
;; (search (car substitution) chunk
;; :start2 start
;; :test (function string=)))
;; (result '()))
;; ((null pos)
;; (cond
;; ((= 0 start)
;; (push chunk result))
;; ((< start (length chunk))
;; (push (displaced-vector chunk start) result)))
;; (nreverse result))
;; (when (< start pos)
;; (push (displaced-vector chunk start pos) result))
;; (push (cdr substitution) result)))
;; chunks)))))
)
(defmacro defentity (name code &optional documentation)
`(progn
......@@ -231,6 +212,8 @@ BUG: We don't manage the encodings, assuming that ISO-Latin-1 is active.
(defentity |amp| 38 "ampersand")
(defentity |gt| 62 "greater than")
(defentity |lt| 60 "less than")
(defentity |quot| 34 "double quote")
(defentity |apo| 39 "quote")
;; The meat:
......
This diff is collapsed.
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment