```;;;; -*- mode:emacs-lisp;coding:utf-8 -*-
;;;;******************************************************************************
;;;;FILE:               pjb-roman.el
;;;;LANGUAGE:           emacs lisp
;;;;SYSTEM:             emacs
;;;;USER-INTERFACE:     emacs
;;;;DESCRIPTION
;;;;
;;;;    This module exports
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon
;;;;MODIFICATIONS
;;;;    199?/??/?? <PJB> Creation.
;;;;BUGS
;;;;LEGAL
;;;;    LGPL
;;;;
;;;;    Copyright Pascal J. Bourguignon 1990 - 2011
;;;;
;;;;    This library is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Lesser General Public
;;;;    version 2 of the License, or (at your option) any later version.
;;;;
;;;;    This library 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
;;;;    Lesser General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU Lesser General Public
;;;;    License along with this library; if not, write to the Free Software
;;;;    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
;;;;
;;;;******************************************************************************
(provide 'pjb-roman)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; triple point of water is 273.16 K
;; ice point is 273.15 K
;; Celcius and Fahrenheit are defined in terms of ice point.

(defun cefak (k)
"Insert at point a string with degree Kelvin, Celcius and Fahrenheit.
(function insert)
(function message))
(format "%10.2f K  %10.2f °C  %10.2f °F   %s"
k
(- k 273.15)
(+ 32.0 (* 1.8 (- k 273.15)))
(let ((c (- k 273.15)))
(cond
((<= k 0) "absolutely cold")
((< c -30) "extremely cold")
((< c 0) "very cold")
((< c 10) "cold")
((< c 15) "supportable")
((< c 20) "not so bad")
((< c 25) "good")
((< c 35) "warm")
((< c 45) "hot")
((< c 55) "rather hot")
((< c 65) "very hot")
((< c 100) "quite really hot")
((< c 10000) "definitely hot")
((< c 100000) "extremely hot")
((< c 1000000) "you won't believe how hot this is hot"))))))

(defun fahrenheit (f)
"Convert degrees Fahrenheit to Celcius and Kelvin."
(interactive "XDegrees Fahrenheit: ")
(cefak (+ 273.15 (/ (- f 32) 1.8))))

(defun celcius (c)
"Convert degrees Celcius to Fahrenheit and Kelvin."
(interactive "XDegrees Celcius: ")
(cefak (+ 273.15 c)))

(defun kelvin (k)
"Convert degrees Kelvin to Fahrenheit and Celcius."
(interactive "XDegrees Kelvin: ")
(cefak k))

(defalias 'C 'celcius)
(defalias 'F 'fahrenheit)
(defalias 'K 'kelvin)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Règles d'écriture des nombres romains :
;; Les chiffres M, C, X, I ne peuvent pas être répétés plus de quatre fois.
;; Les chiffres D, L, V ne peuvent pas être répétés.
;; Les chiffres doivent être écris dans l'ordre : M, D, C, L, X, V, I ;
;; sauf que un I peut précéder V, X, L, ou C, et un X peut précéder L ou C.

;;  romain : milliers centaines .
;;
;;  milliers : | M | M M | M M M | M M M M .
;;
;;  centaines : centaine4 dizaines | D centaine4 dizaines .
;;  centaine4 : | C | C C | C C C | C C C C .
;;
;;  dizaines : dizaine8 | X C unite8 | I C .
;;  dizaine8 : dizaine4 unites | I L | L dizaine3 unites
;;  dizaine4 : dizaine3 | X L .
;;  dizaine3 : | X | X X | X X X .
;;
;;  unites : unite8 | I X .
;;  unite8 : unite4 | V unite3 .
;;  unite4 : unite3 | I V .
;;  unite3 : | I | I I | I I I .

;;----------------------------------------------------------------------
;; Parser
;; ( remaining_char_list value )
;;

(defun roman-parser-make (string)
(list (string-to-list string) 0));;roman-parser-make

(defun roman-parser-curr-char (parser)
(car (car parser)));;roman-parser-curr-char

(defun roman-parser-next-char (parser)
(car (cdr (car parser))));;roman-parser-next-char

(defun roman-parser-fetch-char (parser)
(setcar parser (cdr (car parser))));;roman-parser-fetch-char

(defun roman-parser-string (parser)
(if (roman-parser-curr-char parser)
(apply 'string (car parser))
""));;roman-parser-string

(defun roman-parser-value (parser)
(car (cdr parser)));;roman-parser-value

(setcar (cdr parser) (+ (car (cdr parser)) increment)));;roman-parser-value-add

;;----------------------------------------------------------------------
;; Roman parser
;;

(defun from-roman (r)
;;  romain : milliers centaines .
(let ((p (roman-parser-make r)))
(from-roman-thousands p)
(from-roman-hundreds  p)
(if (roman-parser-curr-char p)
(error (format "Superfluous characters '%s'." (roman-parser-string p))))
(roman-parser-value p)));;from-roman

(defun from-roman-thousands (p)
;;  milliers : | M | M M | M M M | M M M M .
(let ((i 0))
(while (and (< i 4) (equal ?M (roman-parser-curr-char p)))
(roman-parser-fetch-char p)
(setq i (1+ i))))
(if (equal ?M (roman-parser-curr-char p))
(error "Too many Ms.")));;from-roman-thousands

(defun from-roman-hundreds (p)
;;  centaines : centaine4 dizaines | D centaine4 dizaines .
(if (equal ?D (roman-parser-curr-char p))
(progn
(roman-parser-fetch-char p)
(from-roman-hundred4 p)
(from-roman-tens p));;from-roman-hundreds

(defun from-roman-hundred4 (p)
;;  centaine4 : | C | C C | C C C | C C C C .
(let ((i 0))
(while (and (< i 4) (equal ?C (roman-parser-curr-char p)))
(roman-parser-fetch-char p)
(setq i (1+ i))))
(if (equal ?C (roman-parser-curr-char p))
(error "Too many Cs.")));;from-roman-hundred4

(defun from-roman-tens (p)
;;  dizaines : dizaine8 | X C unite8 | I C .
(if (equal ?C (roman-parser-next-char p))
(cond
((equal ?I (roman-parser-curr-char p))
(roman-parser-fetch-char p)
(roman-parser-fetch-char p)
((equal ?X (roman-parser-curr-char p))
(roman-parser-fetch-char p)
(roman-parser-fetch-char p)
(from-roman-unit8 p))
(t (from-roman-ten8 p)))
(from-roman-ten8 p)));;from-roman-tens

(defun from-roman-ten8 (p)
;;  dizaine8 : dizaine4 unites | I L | L dizaine3 unites
(cond
((equal ?I (roman-parser-curr-char p))
(if (equal ?L (roman-parser-next-char p))
(progn
(roman-parser-fetch-char p)
(roman-parser-fetch-char p)
(from-roman-ten4  p)
(from-roman-units p)))
((equal ?L (roman-parser-curr-char p))
(roman-parser-fetch-char p)
(from-roman-ten3  p)
(from-roman-units p))
(t
(from-roman-ten4  p)
(from-roman-units p))));;from-roman-ten8

(defun from-roman-ten4 (p)
;;  dizaine4 : dizaine3 | X L .
(if (and
(equal ?X (roman-parser-curr-char p))
(equal ?L (roman-parser-next-char p)))
(progn
(roman-parser-fetch-char p)
(roman-parser-fetch-char p)
(from-roman-ten3 p)));;from-roman-ten4

(defun from-roman-ten3 (p)
;;  dizaine3 : | X | X X | X X X .
(let ((i 0))
(while (and (< i 3) (equal ?X (roman-parser-curr-char p)))
(roman-parser-fetch-char p)
(setq i (1+ i))))
(if (equal ?X (roman-parser-curr-char p))
(error "Too many Xs.")));;from-roman-ten3

(defun from-roman-units (p)
;;  unites : unite8 | I X .
(if (and
(equal ?I (roman-parser-curr-char p))
(equal ?X (roman-parser-next-char p)))
(progn
(roman-parser-fetch-char p)
(roman-parser-fetch-char p)
(from-roman-unit8 p)));;from-roman-units

(defun from-roman-unit8 (p)
;;  unite8 : unite4 | V unite3 .
(if (equal ?V (roman-parser-curr-char p))
(progn
(roman-parser-fetch-char p)
(from-roman-unit3 p))
(from-roman-unit4 p)));;from-roman-unit8

(defun from-roman-unit4 (p)
;;  unite4 : unite3 | I V .
(if (and
(equal ?I (roman-parser-curr-char p))
(equal ?V (roman-parser-next-char p)))
(progn
(roman-parser-fetch-char p)
(roman-parser-fetch-char p)
(from-roman-unit3 p)));;from-roman-unit4

(defun from-roman-unit3 (p)
;;  unite3 : | I | I I | I I I .
(let ((i 0))
(while (and (< i 3) (equal ?I (roman-parser-curr-char p)))
(roman-parser-fetch-char p)
(setq i (1+ i))))
(if (equal ?I (roman-parser-curr-char p))
(error "Too many Is.")));;from-roman-unit3

;;----------------------------------------------------------------------

(defun to-roman-100 (m c r)
(concat (nth m '("" "M" "MM" "MMM" "MMMM"))
(nth c '("" "C" "CC" "CCC" "CCCC" "D"
"DC" "DCC" "DCCC" "DCCCC"))
r));;to-roman-100

(defun to-roman-10 (m c d r)
(to-roman-100 m c (concat (nth d '("" "X" "XX" "XXX" "XL"
"L" "LX" "LXX" "LXXX" "XC")) r)));;to-roman-10

(defun to-roman (n)
"
RETURN: the number N expressed in roman number notation.
PRE:    1<=N<=4999
"
(cond
((not (integerp n))
(error "The parameter N must be an integer."))
((or (< n 1) (< 4999 n))
(error "The parameter N must be between 1 and 4999 included.")))

(let* ((u (% n 10))
(d (% (/ n 10) 10))
(c (% (/ n 100) 10))
(m (% (/ n 1000) 10))
(r ""))
(cond
((= (+ (* d 10) u) 40) (to-roman-100 m c "XL"))
((= (+ (* d 10) u) 49) (to-roman-100 m c "IL"))
((= (+ (* d 10) u) 99) (to-roman-100 m c "IC"))
(t   (to-roman-10 m c d (nth u '("" "I" "II" "III" "IV" "V"
"VI" "VII" "VIII" "IX")))))));;to-roman

;;----------------------------------------------------------------------

(defun region-to-roman ()
"Replace the region containing a decimal integer by the equivalent roman number."
(interactive)
(let ((r (to-roman (string-to-number
(buffer-substring (region-beginning) (region-end))))))
(delete-region (region-beginning) (region-end))
(insert r)));;region-to-roman

(defun region-from-roman ()
"Replace the region containing a roman number by the equivalent decimal integer."
(interactive)
(let ((n (from-roman  (buffer-substring (region-beginning) (region-end)))))
(delete-region (region-beginning) (region-end))
(insert (format "%d" n))));;region-from-roman

;;----------------------------------------------------------------------

;     (for
;      n 1 4999
;      (condition-case cc
;          (let* ((r (to-roman n))
;                 (m (from-roman r)))
;            (or (= n m)
;                (insert (format  "%4d -> %-20s -> %4d %s\n"
;                                 n r m (if (= n m) "" "***")))))
;        ('error
;         (insert (format "ERROR for %4d [%-20s] : %s\n" n (to-roman n)
;                         (car (cdr cc)))))))
;     (for
;      n 1 4999
;      (insert (format "%4d -> %s\n" n (to-roman n))))

;;;; pjb-roman.el                     -- 2003-09-04 04:41:25 -- pascal   ;;;;```
ViewGit