;;;; -*- 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
;;;; License as published by the Free Software Foundation; either
;;;; 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.
SEE ALSO: fahrenheit (F), celcius (C) and kelvin (K)."
(funcall (if buffer-file-read-only
(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
(defun roman-parser-value-add (parser increment)
(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)
(roman-parser-value-add p 1000)
(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)
(roman-parser-value-add p 500)))
(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)
(roman-parser-value-add p 100)
(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)
(roman-parser-value-add p 99))
((equal ?X (roman-parser-curr-char p))
(roman-parser-fetch-char p)
(roman-parser-fetch-char p)
(roman-parser-value-add p 90)
(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)
(roman-parser-value-add p 49))
(from-roman-ten4 p)
(from-roman-units p)))
((equal ?L (roman-parser-curr-char p))
(roman-parser-fetch-char p)
(roman-parser-value-add p 50)
(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)
(roman-parser-value-add p 40))
(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)
(roman-parser-value-add p 10)
(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)
(roman-parser-value-add p 9))
(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)
(roman-parser-value-add p 5)
(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)
(roman-parser-value-add p 4))
(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)
(roman-parser-value-add p 1)
(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 ;;;;