Tiago Charters work gallery about blog contact

(setq max-lisp-eval-depth 100000
      max-specpdl-size 10000)

Funções auxiliares

(defun list-to-string (l)
  "Return a STRING which is the concatenation of the elements of
L."
  (if (not l)
      nil
    (if (stringp (car l))
        (concat (car l) (list-to-string (cdr l)))
      (list-to-string (cdr l)))))

(defun join-string (xs &optional sep)
  (cond ((null xs) "")
        ((null (cdr xs)) (car xs))
        (t (concat (car xs) (or sep "") (join-string (cdr xs) sep)))))

(defun string-to-strings (s)
    "Convert a string into a list of strings."
    (let ((i (- (length s) 1)) (l '()))
      (while (<= 0 i)
        (setq l (cons (aref s i) l)
              i (- i 1)))
      (mapcar (lambda (x) (char-to-string x)) l)))

Definição das vogais em português

(setq vn (string-to-strings "aeiouáàéíóúâêôAEIOUÁÀÉÍÓÚÂÊÔ"))
(setq vnc (mapcar (lambda (x) (string-to-char x)) vn))

(defun vowelp (v)
  "É v uma vogal? Sim -> t, Não -> nil. "
  (if (eq () (memq  (string-to-char v) vnc)) nil t))

(defun consonantp (v)
  (if (vowelp v) nil t))

(defun tilde-rm (v)
  "ã -> a~, õ -> o~"
  (cond ((eq  (string-to-char '"ã") (string-to-char v)) "a~")
        ((eq (string-to-char '"õ") (string-to-char v)) "o~")
        (v)))

(defun tilde-rm-string (str)
"Avião Cão-> Avia~o Ca~o"
  (join-string (mapcar (lambda (x) (tilde-rm x)) (string-to-strings str))))

(defun m (str)
  "#CV como está definido no artigo original do Porter"
  (let* ((i 0) (count 0))
    (while (< i (- (length (sts-rm-tnil str)) 1))
      (if (not (eq (nth i (sts-rm-tnil str)) (nth (+ i 1) (sts-rm-tnil str))))
          (setq count (+ 1 count)))
      (setq i (+ i 1)))
    (if (evenp  count) (/ count 2) (/ (+ 1 count) 2))))

(defun R1 (str)
  "Returns R1 part of the word."
  (let*  ((lstr (string-to-strings(tilde-rm-string str))))
    (if (> (length  lstr) 1)
        (if (vowelp (car lstr))
            (if (consonantp (cadr lstr))
                (join-string (cddr lstr))
              (R1 (join-string (cdr lstr))))
          (R1 (join-string (cdr lstr))))
      )))

(defun R2 (str)
  "Returns R1 part of R2."
  (R1 (R1 str)))

(defun RV (str)
  "Retunrs de RV part"
  (let*  ((lstr (string-to-strings(tilde-rm-string str))))
  (cond
   ((consonantp (cadr lstr ))
    (if (vowelp (caddr lstr))
        (if (consonantp (car (cdddr lstr)))
            (join-string (cdddr lstr)) (join-string (cddddr lstr)))
      ((and (vowelp (car lstr)) (vowelp (cadr lstr)))
       (join-string (cdddr lstr)))))
   ((> (length  lstr) 3)  (join-string (cdddr lstr))))))

(defun sort-list-words-length (lstr)
  "Ordena as palavras, numa lista, por ordem decrescente do número de letras."
  (let ((j 0))
    (while (<= j (length lstr))
      (let ((i 0))
        (while (<= i (length lstr))
          (if (< (length (nth i lstr)) (length (nth (+ 1 i) lstr)))
              (swap lstr i (+ 1 i)) nil)
          (setq i (+ 1 i))))
  (setq j (+ 1 j))))
  lstr)

Lista de sufixos

(setq list-suff
      '("eza" "ezas" "ico" "ica" "icos" "icas" "ismo" "ismos" "ável"
	"ível" "ista" "istas" "oso" "osa" "osos" "osas" "amento"
	"amentos" "imento" "imentos" "adora" "ador" "ação" "adoras"
	"adores" "ações" "ante" "antes" "ância"))

(setq list-suff-verbs
     '("ada" "ida" "ia" "aria" "eria" "iria" "ará" "ara" "erá" "era" "irá" "ava" "asse"
       "esse" "isse" "aste" "este" "iste" "ei" "arei" "erei" "irei" "am" "iam" "ariam" "eriam"
       "iriam" "aram" "eram" "iram" "avam" "em" "arem" "erem" "irem" "assem" "essem" "issem"
       "ado" "ido" "ando" "endo" "indo" "arão" "erão" "irão" "ar" "er" "ir" "as" "adas" "idas"
       "ias" "arias" "erias" "irias" "arás" "aras" "erás" "eras" "irás" "avas" "es" "ardes"
       "erdes" "irdes" "ares" "eres" "ires" "asses" "esses" "isses" "astes" "estes" "istes"
       "is" "ais" "eis" "íeis" "aríeis" "eríeis" "iríeis" "áreis" "areis" "éreis" "ereis"
       "íreis" "ireis" "ásseis" "ésseis" "ísseis" "áveis" "ados" "idos" "ámos" "amos"
       "íamos" "aríamos" "eríamos" "iríamos" "áramos" "éramos" "íramos" "ávamos" "emos"
       "aremos" "eremos" "iremos" "ássemos" "êssemos" "íssemos" "imos" "armos" "ermos"
       "irmos" "eu" "iu" "ou" "ira" "iras"))

(setq list-res-suff '("os" "a" "i" "o" "á" "í" "ó"))

Alguns testes

(R1 "Aleatoriamente" );"eatoriamente"
(R2 "Aleatoriamente" );"oriamente"
(RV "Aleatoriamente" );"toriamente"

---

For attribution, please cite this page as:

Charters, T., "Algumas funções em Lisp para o algoritmo de Porter": https://nexp.pt/porter.html (16-02-2026 [16:03])

---

(cc-by-sa) Tiago Charters - tiagocharters@nexp.pt