/[cmucl]/src/tools/piglatin.lisp
ViewVC logotype

Contents of /src/tools/piglatin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Sun Apr 3 15:19:14 2011 UTC (3 years ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, HEAD
Changes since 1.4: +1 -1 lines
Order the header in the same order as what the tools tend to produce
(at least on my Mac).
1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER -*-
2 ;;;
3 ;;; A very rudimentary machine translator to convert English to Pig
4 ;;; Latin. Written by Paul Foley.
5 ;;;
6 ;;; DO-TRANSLATIONS will translate all of the pot files in the given
7 ;;; directory, placing the translations in the subdirectory
8 ;;; en@piglatin/LC_MESSAGES.
9
10 (in-package "CL-USER")
11
12 (defun latinize-1 (word)
13 (cond ((string= word "I") "Iway")
14 ((string= word "a") "away")
15 ((string= word "A") "Away")
16 ((<= (length word) 1) word)
17 (t
18 (let ((case (cond ((every #'upper-case-p word) :uppercase)
19 ((upper-case-p (char word 0)) :capitalized)
20 (t :lowercase)))
21 (orig-word word)
22 (word (string-downcase word)))
23 (flet ((casify (string)
24 (case case
25 (:uppercase (nstring-upcase string))
26 (:lowercase (nstring-downcase string))
27 (:capitalized (nstring-capitalize string)))))
28 (cond ((and (char= (char word 0) #\*)
29 (char= (char word (1- (length word))) #\*))
30 orig-word)
31 ((eq case :uppercase)
32 ;; For CMUCL's docstrings, if the word is
33 ;; uppercase, let's not change it. This usually
34 ;; means it a reference to either a Lisp function
35 ;; or variable that should probably not be
36 ;; changed.
37 (casify word))
38 ((position (char word 0) "AEIOUaeiou")
39 (casify (concatenate 'string word "way")))
40 ((and (> (length word) 3)
41 (member (subseq word 0 3)
42 '("sch" "str")
43 :test #'string=))
44 (casify (concatenate 'string (subseq word 3)
45 (subseq word 0 3) "ay")))
46 ((member (subseq word 0 2)
47 '("br" "bl" "ch" "cr" "cl" "dr" "fr" "fl" "gr" "gh"
48 "gl" "kr" "kl" "mn" "pr" "ph" "pl" "qu" "rh" "sp"
49 "sh" "sl" "sc" "sn" "tr" "th" "wr" "wh" "zh")
50 :test #'string=)
51 (casify (concatenate 'string (subseq word 2)
52 (subseq word 0 2) "ay")))
53 (t
54 (casify (concatenate 'string (subseq word 1)
55 (subseq word 0 1) "ay")))))))))
56
57 (defun latinize (string)
58 (flet ((word-constituent-p (c)
59 (or (char= c #\*)
60 (alpha-char-p c)))
61 (word-constituent-*-p (c)
62 (or (char= c #\*)
63 (char= c #\-)
64 (alpha-char-p c))))
65 (with-output-to-string (str)
66 (loop for i = -1 then k
67 as j = 0 then
68 (or (position-if #'word-constituent-p string :start k)
69 (length string))
70 as k = (if (and (< j (length string))
71 (char= (char string j) #\*))
72 (position-if-not #'word-constituent-*-p string :start j)
73 (position-if-not #'word-constituent-p string :start j))
74 unless (minusp i) do (write-string string str :start i :end j)
75 do (write-string (latinize-1 (subseq string j k)) str)
76 while k))))
77
78
79 (defconstant +piglatin-header+
80 "\"Project-Id-Version: CMUCL ~X\\n\"
81 \"PO-Revision-Date: YEAR-MO-DA HO:MI +ZONE\\n\"
82 \"Last-Translator: Automatic translation\\n\"
83 \"Language-Team: Pig Latin (auto-translated)\\n\"
84 \"Language: Pig Latin\\n\"
85 \"MIME-Version: 1.0\\n\"
86 \"Content-Type: text/plain; charset=UTF-8\\n\"
87 \"Content-Transfer-Encoding: 8bit\\n\"
88 \"Plural-Forms: nplurals=2; plural=(n != 1);\\n\"
89 ")
90
91
92 (defun read-pot-string (stream char)
93 (declare (ignore char))
94 (let ((backslash nil))
95 (with-output-to-string (out)
96 (loop for ch = (read-char stream t nil t)
97 until (and (not backslash) (char= ch #\")) do
98 (write-char ch out)
99 (cond (backslash (setq backslash nil))
100 ((char= ch #\\) (setq backslash t)))))))
101
102 (defun latinize-pot (in out)
103 (let ((state 0)
104 (string nil)
105 (plural nil)
106 (count 0))
107 (with-open-file (pot in :direction :input :external-format :utf-8)
108 (with-open-file (po out :direction :output :external-format :utf-8
109 :if-does-not-exist :create
110 :if-exists :supersede)
111 (let ((*readtable* (copy-readtable nil)))
112 (set-macro-character #\# (lambda (stream char)
113 (declare (ignore char))
114 (list (read-line stream t nil t))))
115 (set-macro-character #\" #'read-pot-string)
116 (loop for item = (read pot nil pot) until (eq item pot) do
117 (cond ((consp item)
118 (write-char #\# po) (write-string (car item) po) (terpri po))
119 ((eq item 'msgid)
120 (write-string "msgid " po)
121 (incf count)
122 (setq state 1))
123 ((eq item 'msgid_plural)
124 (write-string "msgid_plural " po)
125 (setq state 2))
126 ((eq item 'msgstr)
127 (write-string "msgstr " po)
128 (when (equal string '(""))
129 (format po +piglatin-header+ (c::backend-fasl-file-version c::*native-backend*))
130 (setq string nil))
131 (dolist (x string)
132 (write-char #\" po)
133 (write-string x po)
134 (write-char #\" po)
135 (terpri po))
136 (terpri po)
137 (setq state 0 string nil))
138 ((eq item 'msgstr[0])
139 (write-string "msgstr[0] " po)
140 (dolist (x string)
141 (write-char #\" po)
142 (write-string x po)
143 (write-char #\" po)
144 (terpri po))
145 (write-string "msgstr[1] " po)
146 (dolist (x plural)
147 (write-char #\" po)
148 (write-string x po)
149 (write-char #\" po)
150 (terpri po))
151 (terpri po)
152 (setq state 0 string nil plural nil))
153 ((not (stringp item)) (error "Something's wrong"))
154 ((= state 1)
155 (write-char #\" po)
156 (write-string item po)
157 (write-char #\" po)
158 (terpri po)
159 (setq string (nconc string (list (latinize item)))))
160 ((= state 2)
161 (write-char #\" po)
162 (write-string item po)
163 (write-char #\" po)
164 (terpri po)
165 (setq plural (nconc plural (list (latinize item))))))))))
166 (format t "~&Translated ~D messages~%" count)))
167
168 ;; Translate all of the pot files in DIR
169 (defun do-translations (&optional (dir "target:i18n/locale"))
170 (dolist (pot (directory (merge-pathnames (make-pathname :name :wild :type "pot" :version :newest)
171 dir)))
172 (let ((po (merge-pathnames (make-pathname :directory '(:relative "en@piglatin" "LC_MESSAGES")
173 :name (pathname-name pot) :type "po")
174 dir)))
175 (format t "~A -> ~A~%" pot po)
176 (latinize-pot pot po))))

  ViewVC Help
Powered by ViewVC 1.1.5