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

Contents of /src/tools/piglatin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide 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 rtoy 1.3 ;;; -*- 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 rtoy 1.2 (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 rtoy 1.4 "\"Project-Id-Version: CMUCL ~X\\n\"
81 rtoy 1.2 \"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 rtoy 1.5 \"Language: Pig Latin\\n\"
85 rtoy 1.2 \"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 rtoy 1.4 (format po +piglatin-header+ (c::backend-fasl-file-version c::*native-backend*))
130 rtoy 1.2 (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