2019/12/30

MFCC 梅爾倒頻譜係數

MFCC是Mel-Frequency Cepstral Coefficients 梅爾頻率倒譜係數的縮寫,它是在1980年由 S.B. Davis和 Paul Mermelstein 提出來的,在語音辨識(Speech Recognition)和語者辨識(Speaker Recognition)方面,最常用到的語音特徵就是「梅爾倒頻譜係數」,此參數考慮到人耳對不同頻率的感受程度,因此特別適合用在語音辨識。

MFCC特徵提取包含兩個關鍵步驟:梅爾頻率分析和倒譜分析

在訊號處理(Signal Processing)中,梅爾倒頻譜(Mel-Frequency Cepstrum, MFC)係一個可用來代表短期音訊的頻譜,其原理根基於以非線性的梅爾刻度(mel scale)表示的對數頻譜(spectrum)及其線性餘弦轉換(linear cosine transform)之上。

梅爾倒頻譜係數 (Mel-Frequency Cepstral Coefficients, MFCC)是一組用來建立梅爾倒頻譜的關鍵係數。由音樂訊號當中的片段,我們可以得到一組足以代表此音樂訊號之倒頻譜,而梅爾倒頻譜係數即是從這個倒頻譜中推得的倒頻譜(也就是頻譜的頻譜)。與一般的倒頻譜不同 ,梅爾倒頻譜最大的特色在於,於梅爾倒頻譜上的頻帶是均勻分布於梅爾刻度上的,也就是說,這樣的頻帶會較一般我們所看到、線性的倒頻譜表示方法,和人類非線性的聽覺系統(audio system)更為接近。在音訊壓縮的技術中,常常使用梅爾倒頻譜來處理。

在語音識別(Speech Recognition)和話者識別(Speaker Recognition)方面,最常用到的語音特徵就是梅爾倒譜系數(Mel-scale Frequency Cepstral Coefficients,簡稱MFCC)。

人類聽覺特性

人耳對不同強度、不同頻率聲音的聽覺範圍稱為聲域。在人耳的聲域範圍內,聲音聽覺心理的主觀感受主要有響度、音高、音色等特徵和掩蔽效應、高頻定位等特性。其中響度、音高、音色可以在主觀上用來描述具有振幅、頻率和相位三個物理量的任何複雜的聲音,故又稱為聲音「三要素」;而在多種音源場合,人耳掩蔽效應等特性更重要,它是心理聲學的基礎。

  1. 響度

    又稱聲強或音量,它表示的是聲音能量的強弱程度,主要取決於聲波振幅的大小。聲音的響度一般用聲壓(達因/平方釐米)或聲強(瓦特/平方釐米)來計量,聲壓的單位為帕(Pa),它與基準聲壓比值的對數值稱為聲壓級,單位是分貝(dB)。對於響度的心理感受,一般用單位宋(Sone)來度量,並定義lkHz、40dB的純音的響度為1宋。響度的相對量稱為響度級,它表示的是某響度與基準響度比值的對數值,單位為口方(phon),即當人耳感到某聲音與1kHz單一頻率的純音同樣響時,該聲音聲壓級的分貝數即為其響度級。

    正常人聽覺的強度範圍為0dB—140dB(也有人認為是-5dB—130dB)。固然,超出人耳的可聽頻率範圍(即頻域)的聲音,即使響度再大,人耳也聽不出來(即響度為零)。在人耳的可聽頻域內,若聲音弱到或強到一定程度,人耳同樣是聽不到的。當聲音減弱到人耳剛剛可以聽見時,此時的聲音強度稱為「聽閾」。一般以1kHz純音為準進行測量,人耳剛能聽到的聲壓為0dB(通常大於0.3dB即有感受)、聲強為10-16W/cm2 時的響度級定為0口方。而當聲音增強到使人耳感到疼痛時,這個閾值稱為「痛閾」。仍以1kHz純音為準來進行測量,使 人耳感到疼痛時的聲壓級約達到140dB左右。

    人耳對3kHz—5kHz聲音最敏感,幅度很小的聲音信號都能被人耳聽到,而在低頻區(如小於800Hz)和高頻區(如大於5kHz)人耳對聲音的靈敏度要低得多。響度級較小時,高、低頻聲音靈敏度降低較明顯,而低頻段比高頻段靈敏度降低更加劇烈,一般應特別重視加強低頻音量。通常200Hz--3kHz語音聲壓級以60dB—70dB為宜,頻率範圍較寬的音樂聲壓以80dB—90dB最佳。

  2. 音高

    也稱音調,表示人耳對聲音調子高低的主觀感受。客觀上音高大小主要取決於聲波基頻的高低,頻率高則音調高,反之則低,單位用赫茲(Hz)表示。主觀感覺的音高單位是「美」,通常定義響度為40方的1kHz純音的音高為1000美。赫茲與「美」同樣是表示音高的兩個不同概念而又有聯繫的單位。

    人耳對響度的感覺有一個從聞閾到痛閾的範圍。人耳對頻率的感覺同樣有一個從最低可聽頻率20Hz到最高可聽頻率別20kHz的範圍。響度的測量是以1kHz純音為基準,同樣,音高的測量是以40dB聲強的純音為基準。

    實驗證明,音高與頻率之間的變化並非線性關係,除了頻率之外,音高還與聲音的響度及波形有關。音高的變化與兩個頻率相對變化的對數成正比。不管原來頻率多少,只要兩個40dB的純音頻率都增加1個倍頻程(即1倍),人耳感受到的音高變化則相同。在音樂聲學中,音高的連續變化稱為滑音,1個倍頻程相當於樂音提高了一個八度音階。根據人耳對音高的實際感受,人的語音頻率範圍可放寬到80Hz--12kHz,樂音較寬,效果音則更寬。

  3. 音色

    又稱音品,由聲音波形的諧波頻譜和包絡決定。聲音波形的基頻所產生的聽得最清楚的音稱為基音,各次諧波的微小振動所產生的聲音稱泛音。單一頻率的音稱為純音,具有諧波的音稱為複音。每個基音都有固有的頻率和不同響度的泛音,藉此可以區別其它具有相同響度和音調的聲音。

人耳的掩蔽效應

一個較弱的聲音(被掩蔽音)的聽覺感受被另一個較強的聲音(掩蔽音)影響的現象稱為人耳的「掩蔽效應」。被掩蔽音單獨存在時的聽閾分貝值,或者說在安靜環境中能被人耳聽到的純音的最小值稱為絕對聞閾。實驗表明,3kHz—5kHz絕對聞閾值最小,即人耳對它的微弱聲音最敏感;而在低頻和高頻區絕對聞閾值要大得多。在800Hz--1500Hz範圍內聞閾隨頻率變化最不顯著,即在這個範圍內語言可儲度最高。在掩蔽情況下,提高被掩蔽弱音的強度,使人耳能夠聽見時的聞閾稱為掩蔽聞閾(或稱掩蔽門限),被掩蔽弱音必須提高的分貝值稱為掩蔽量(或稱閾移)。

純音對純音、噪音對純音的掩蔽效應結論如下:

  • 純音間的掩蔽

    • 對處於中等強度時的純音最有效的掩蔽是出現在它的頻率附近。
    • 低頻的純音可以有效地掩蔽高頻的純音,而反過來則作用很小。
  • 噪音對純音的掩蔽噪音是由多種純音組成,具有無限寬的頻譜

若掩蔽聲為寬頻噪聲,被掩蔽聲為純音,則它產生的掩蔽門限在低頻段一般高於噪聲功率譜密度17dB,且較平坦;超過500Hz時大約每十倍頻程增大10dB。若掩蔽聲為窄帶噪聲,被掩蔽聲為純音,則情況較複雜。其中位於被掩蔽音附近的由純音份量組成的窄帶噪聲即臨界頻帶的掩蔽作用最明顯。

當我們改變窄頻帶聲音刺激(narrowband sound stimulus)時,其聲音成分若跨越某一頻率,則聽覺上會感到有差異,而在一頻率範圍內,則感覺不到差異,這個頻率範圍稱臨界頻帶(Critical Band)

  • 在人類聽覺範圍內 20Hz--16kHz範圍,可以分成24個臨界頻帶

根據人耳聽覺機理的研究發現,人耳對不同頻率的聲波有不同的聽覺敏感度。從200Hz到5000Hz的語音訊號對語音的清晰度影響對大。兩個響度不等的聲音作用於人耳時,則響度較高的頻率成分的存在會影響到對響度較低的頻率成分的感受,使其變得不易察覺,這種現象稱為掩蔽效應。當某個純音位於掩蔽聲的臨界頻帶之外時,掩蔽效應仍然存在。


掩蔽類型

  • 低頻的聲音傾向於遮蔽高頻的聲音

​ 掩蔽聲與被掩蔽聲同時作用時發生掩蔽效應,又稱同時掩蔽。這時,掩蔽聲在掩蔽效應發生期間一直起作用,是一種較強的掩蔽效應。通常,頻域中的一個強音會掩蔽與之同時發聲的附近的弱音,弱音離強音越近,一般越容易被掩蔽;反之,離強音較遠的弱音不容易被掩蔽。例如,—個1000Hz的音比另一個900Hz的音高18dB,則900Hz的音將被1000Hz的音掩蔽。而若1000Hz的音比離它較遠的另一個1800Hz的音高18dB,則這兩個音將同時被人耳聽到。若要讓1800Hz的音聽不到,則1000Hz的音要比1800Hz的音高45dB。一般來說,低頻的音容易掩蔽高頻的音;在距離強音較遠處,絕對聞閾比該強音所引起的掩蔽閾值高,這時,噪聲的掩蔽閾值應取絕對聞閾。

  • 聲音在聽覺器官中,傳遞時間延遲所造成的遮蔽現象,稱時間遮蔽

由於頻率較低的聲音在內耳蝸基底膜上行波傳遞的距離大於頻率較高的聲音,故一般來說,低音容易掩蔽高音,而高音掩蔽低音較困難。在低頻處的聲音掩蔽的臨界頻寬較高頻要小。

時域掩蔽是指掩蔽效應發生在掩蔽聲與被掩蔽聲不同時出現時,又稱異時掩蔽。異時掩蔽又分為導前掩蔽和滯後掩蔽。若掩蔽聲音出現之前的一段時間內發生掩蔽效應,則稱為導前掩蔽;否則稱為滯後掩蔽。產生時域掩蔽的主要原因是人的大腦處理信息需要花費一定的時間,異時掩蔽也隨著時間的推移很快會衰減,是一種弱掩蔽效應。一般情況下,導前掩蔽只有3ms—20ms,而滯後掩蔽卻可以持續50ms—100ms。

所以,人們從低頻到高頻這一段頻帶內按臨界頻寬的大小由密到疏安排一組帶通濾波器,對輸入訊號進行濾波。將每個帶通濾波器輸出的訊號能量作為訊號的基本特徵,對此特徵經過進一步處理後就可以作為語音的輸入特徵。

梅爾刻度是一種基於人耳對等距的音高(pitch)變化的感官判斷而定的非線性頻率刻度。當在梅爾刻度上面上是均勻分度的話,對於的赫茲之間的距離將會越來越大。梅爾刻度的濾波器組在低頻部分的解析度高,跟人耳的聽覺特性是相符的,這也是梅爾刻度的物理意義所在。

由於這種特徵不依賴於訊號的性質,對輸入訊號不做任何的假設和限制,又利用了聽覺模型的研究成果。因此,這種引數比基於聲道模型的LPCC相比具有更好的魯邦性,更符合人耳的聽覺特性,且信噪比降低時仍然具有較好的識別效能。

梅爾刻度與頻率的關係可用下式近似表示, f 為頻率,單位為 Hz。

\(Mel(f) = 2595 * log(1 + \frac{f}{700}) = 1125*ln(1+\frac{f}{700})\)

MFCC 的計算過程

  1. 預強調(Pre-emphasis):將語音訊號 s(n) 通過一個高通濾波器:\(H(z)=1-a*z^{-1}\) 其中 a 介於 0.9 和 1.0 之間。若以時域的運算式來表示,預強調後的訊號 \(s_2(n)\) 為 \(s_2(n) = s(n) - a*s(n-1)\) 。這個處理目的就是為了消除發聲過程中聲帶和嘴唇的效應,來補償語音信號受到發音系統所壓抑的高頻部分。(另一種說法則是要突顯在高頻的共振峰。)

    經過了預強調之後,聲音變的比較尖銳清脆,但是音量也變小了

  2. 音框化(Frame blocking):先將 N 個取樣點集合成一個觀測單位,稱為音框(Frame),通常 N 的值是 256 或 512,涵蓋的時間約為 20~30 ms 左右。為了避免相鄰兩音框的變化過大,所以我們會讓兩相鄰因框之間有一段重疊區域,此重疊區域包含了 M 個取樣點,通常 M 的值約是 N 的一半或 1/3。通常語音辨識所用的音訊的取樣頻率為 8 KHz或 16 KHz,以 8 KHz 來說,若音框長度為 256 個取樣點,則對應的時間長度是 256/8000*1000 = 32 ms。

  3. 漢明窗(Hamming window):將每一個音框乘上漢明窗,以增加音框左端和右端的連續性(請見下一個步驟的說明)。假設音框化的訊號為 \(S(n), n = 0,…N-1\)。那麼乘上漢明窗後為 \(S'(n) = S(n)*W(n)\),此 W(n) 形式如下:

    \(W(n, a) = (1 - a) - acos(2pn/(N-1)),0≦n≦N-1\)

    不同的 a 值會產生不同的漢明窗

    一般都取 a = 0.46

  4. 快速傅利葉轉換(Fast Fourier Transform, or FFT):由於訊號在時域(Time domain)上的變化通常很難看出訊號的特性,所以通常將它轉換成頻域(Frequency domain)上的能量分佈來觀察,不同的能量分佈,就能代表不同語音的特性。所以在乘上漢明窗後,每個音框還必需再經過 FFT 以得到在頻譜上的能量分佈。

    乘上漢明窗的主要目的,是要加強音框左端和右端的連續性,這是因為在進行 FFT 時,都是假設一個音框內的訊號是代表一個週期性訊號,如果這個週期性不存在,FFT 會為了要符合左右端不連續的變化,而產生一些不存在原訊號的能量分佈,造成分析上的誤差。當然,如果我們在取音框時,能夠使音框中的訊號就已經包含基本週期的整數倍,這時候的音框左右端就會是連續的,那就可以不需要乘上漢明窗了。但是在實作上,由於基本週期的計算會需要額外的時間,而且也容易算錯,因此我們都用漢明窗來達到類似的效果。

  5. 三角帶通濾波器(Triangular Bandpass Filters):將能量頻譜能量乘以一組 20 個三角帶通濾波器,求得每一個濾波器輸出的對數能量(Log Energy)。必須注意的是:這 20 個三角帶通濾波器在「梅爾頻率」(Mel Frequency)上是平均分佈的,而梅爾頻率和一般頻率 f 的關係式如下:

    \(Mel(f) = 2595 * log(1 + \frac{f}{700}) = 1125*ln(1+\frac{f}{700})\)

    梅爾頻率代表一般人耳對於頻率的感受度,由此也可以看出人耳對於頻率 f 的感受是呈對數變化的。

    • 在低頻部分,人耳感受是比較敏銳
    • 在高頻部分,人耳的感受就會越來越粗糙

    三角帶通濾波器有兩個主要目的:

    • 對頻譜進行平滑化,並消除諧波的作用,突顯原先語音的共振峰。(因此一段語音的音調或音高,是不會呈現在 MFCC 參數內,換句話說,以 MFCC 為特徵的語音辨識系統,並不會受到輸入語音的音調不同而有所影響。)
    • 降低資料量
  6. 離散餘弦轉換(Discrete cosine transform, or DCT):將上述的 20 個對數能量 Ek帶入離散餘弦轉換,求出 L 階的 Mel-scale Cepstrum 參數,這裡 L 通常取 12。

    離散餘弦轉換公式如下:\(C_m=\sum_{k=1}^{N}cos[m*(k-0.5)*p/N]*E_k, m=1,2, ..., L\) 其中 \(E_k\) 是由前一個步驟所算出來的三角濾波器和頻譜能量的內積值,N 是三角濾波器的個數。由於之前作了 FFT,所以採用 DCT 轉換是期望能轉回類似 Time Domain 的情況來看,又稱 Quefrency Domain,其實也就是 Cepstrum。又因為之前採用 Mel- Frequency 來轉換至梅爾頻率,所以才稱之Mel-scale Cepstrum。

  7. 對數能量(Log energy):一個音框的音量(即能量),也是語音的重要特徵,而且非常容易計算。因此我們通常再加上一個音框的對數能量(定義為一個音框內訊號的平方和,再取以 10 為底的對數值,再乘以 10),使得每一個音框基本的語音特徵就有 13 維,包含了 1 個對數能量和 12 個倒頻譜參數。(若要加入其他語音特徵以測試辨識率,也可以在此階段加入,這些常用的其他語音特徵,包含音高、過零率、共振峰等。)

  8. 差量倒頻譜參數(Delta cepstrum):雖然已經求出 13 個特徵參數,然而在實際應用於語音辨識時,我們通常會再加上差量倒頻譜參數,以顯示倒頻譜參數對時間的變化。它的意義為倒頻譜參數相對於時間的斜率,也就是代表倒頻譜參數在時間上的動態變化,公式如下:

    \(△C_m(t) = \frac{𝜕 C_m(t)}{𝜕t} = [\sum_{t=-M}^{M}C_m(t+t)t] / [\sum_{t=-M}^{M}t^2] \)

    這裡 M 的值一般是取 2 或 3。因此,如果加上差量運算,就會產生 26 維的特徵向量;如果再加上差差量運算,就會產生 39 維的特徵向量。

    一般在 PC 上進行的語音辨識,就是使用 39 維的特徵向量。

References

梅爾倒頻譜 wiki

語音特徵引數MFCC提取過程詳解

聲學特徵提取:梅爾頻率倒譜係數MFCC

Kaldi的MFCC特徵提取代碼分析

梅爾倒頻譜係數.ppt

聲音聽覺理論概述

chap11 speaker identification

Audio Signal Processing and Recognition (音訊處理與辨識) Roger Jang (張智星)

MFCC

語音處理中MFCC(Mel頻率倒譜系數)對應的物理含義是什麼?它計算出的那幾個系數能反映什麼樣特徵?

語音特徵參數MFCC提取過程詳解

聲學特徵(二) MFCC特徵原理

Day 25:自動語音識別(Automatic Speech Recognition) -- 觀念與實踐

Building a Dead Simple Speech Recognition Engine using ConvNet in Keras

2019/12/23

praat

praat 是一款跨平台的多功能語音學專業軟體,主要用於對數位化的語音信號進行分析、標註、處理及合成等實驗,同時生成各種語圖和文字報表。

Praat的主要功能是對自然語言的語音信號進行採集、分析和標註,並執行包括變換和濾波等在內的多種處理任務。作為分析結果的文字報表和語圖,不但可以輸出到 PC 檔案中和終端顯示器上,更能夠輸出為精緻的向量圖或位圖,供寫作和印刷學術論文與專著使用。此外,Praat還可用於合成語音或聲音、統計分析語言學數據、輔助語音教學測試。

基本功能

錄音

在 Praat Objects -> 上面的選單 New -> Record mono sound -> (預設 sample rate 為 44100 Hz) -> Record -> (Play 可播放剛剛路的聲音 ) -> Save to list

View & Edit

  • 上面是 wav 的波形,中間是聲譜 (spectrum),代表聲音在每一個頻率的能量大小,越黑代表越強。在上面選單 Spectrum -> Show spectrum 可選擇要不要顯示 spectrum
  • 藍色線條就是 Pitch 音高 (代表聲帶震動的快慢,震動越快,音高會越高。) 在上面 Pitch -> Show pitch 可以將 pitch 關掉
  • Intensity 強度、音量,在選單 Intensity -> Show intensity 可顯示黃色線條 intensity
  • Formant 共振峰 是用來描述聲學共振現象的一種概念,在語音科學及語音學中,描述的是人類聲道中的共振情形。

note:

  • 音量(Volume):代表聲音的大小,可由聲音訊號的震幅來類比,震幅越大,代表此聲音波形的音量越大。音量又稱為能量(Energy)或強度(Intensity)等。
  • 音高(Pitch):代表聲音的高低,可由基本頻率(Fundamental Frequency)來類比,這是基本週期(Fundamental Period)的倒數。聲音的基本頻率越高,代表音高越高;反之,聲音的基本頻率越低,代表音高越低。
  • 音色(Timbre):代表聲音的內容(例如英文的母音),可由每一個波形在一個基本週期的變化來類比。不同的音色即代表不同的音訊內容,例如不同的字母有不同的發音,都是由於音色不同而產生。

如果是用人聲來說明,這些語音特徵的物理意義如下:

  • 音量:代表肺部壓縮力量的大小,力量越大,音量越大。
  • 音高:代表聲帶震動的快慢,震動越快,音高會越高。
  • 音色:代表嘴唇和舌頭的位置和形狀,不同的位置和形狀,就會產生不同的語音內容。

選取後,點中間灰色區塊的秒數長度的部分,就可以播放聲音。點 "Visible part" 或 "Total duration" 可播放整個音檔。

在 Edit -> Set selection to zero,可以將選取起來的雜音部分都設定為 0,也就是刪除那一部分的聲音的意思。

Edit -> Reverse selection,可將聲音倒過來。就等於將聲音倒著播放。

音檔標注

  1. Open -> Read from file 讀取語音 wav 檔

  2. Annotate -> To TextGrid 產生一個空白的標註文件。要先規劃好對這個聲音文件要標註幾層訊息,通常會標註音素 (phone)、音節 (syllable)、字詞。在 All tier names: 填上 phon syllable。

  3. 目前先在 All tier names 填上 sentence,清除 "wichi of these are point tiers?"

  4. 同時選取聲音文件跟 TextGrid,點 View & Edit 進行標注。標注時,聽辨邊界,並查閱語圖資訊,確定音素與音節的邊界

  5. 點擊剛剛聽到的單字的起點,點中間 sentence 裡面的圓圈,設定單字起點。同樣標記出終點 boundary。

  1. 可在 Tier -> add interval tier ,增加一層標記

    1. 有另一種 Point tier,可用來標記 事件

    1. File -> Save TextGrid as text file 可將標記存成文字檔

    2. 在 Praat Obejcts 畫面,選語音,Save -> Save as WAV file 可將剛剛修改過的 wav 存成另一個 wav file

  2. 把 Parrat 關掉時,會將選取的 wav, TextGrid 都清除。Open -> Open from file 可將剛剛存的 wav, TextGrid 選取回來

Drawing

可將 wav & textgrid 同時選取,並點 Praat Objects 右邊的 Draw,就會在 Praat Picture 出現圖檔。點擊 Draw 之前,可先在 Praat Picture 重新把藍色框框範圍改為 9x6,再 Draw,就可得到比較大的圖檔。

畫圖時,有個 "Garnish" 選項,如果有打勾,畫圖時就會增加座標的資訊。如果沒有,就只會畫出線條。

Combine

如果已經有 150 個單字 wav以及 TextGrid,可同時將 150 個 wav 讀取進來,然後用 Combine -> Concatenate recoverably 將 150 個單字及 TextGrid 合併為一個檔案以及一個 TextGrid。

共振峰

ref:

共振峰 wiki

什麼是共振峰?

12-1 共振峰

共振峰(formant)是用來描述聲學共振現象的一種概念,在語音學中,描述的是人類聲道中的共振情形。常用的量測方法是由頻譜分析或聲譜圖(spectrogram)中,尋找頻譜中的峰值。

人類說話或唱歌產生的聲音包含許多不同的頻率,共振峰是這些頻率中較有意義的部分。定義上,人類若想分辨幾個不同的元音,我們所需要的資訊是完全可以被量化的。共振峰是使聽者能夠區分元音的關鍵泛音。大部份的這些共振峰是由管內或腔體的共振產生,但是有些哨音是由文丘裡效應中的低壓區域週期性回縮產生。

頻率最低的共振峰頻率稱為 f1,第二低的是 f2,而第三低的是 f3(基頻一般以 f0 標示)。絕大多部分的情形是,前兩個共振峰,f1 和 f2 就足以劃分不同元音。這兩個共振峰可以描述元音的開/閉、前/後兩個維度(過去傳統上把這和舌頭的位置聯結在一起,不過這並不完全精確)。因此開元音如 [a] 有比較高的第一共振峰頻率f1,而閉元音如 [i u] 的則比較低;前元音如 [i] 的第二共振峰頻率 f2 較高,後元音如 [u] 的則比較低。元音幾乎都有四個以上的共振峰,有時還會超過六個。然而,前兩個共振峰還是最關鍵的。通常我們會用第一共振峰對第二共振峰的 關係圖描述不同元音的性質。但這不足以描述某些元音的性質,例如圓唇與否。圓唇會降低 f3,該效果對高前元音最明顯。


"音高比較低的共振峰是第一共振峰,另一個就是第二共振峰"

元音,或稱母音,是音素的一種,與輔音相對。元音是在發音過程中由氣流通過口腔而不受阻礙發出的音。

輔音,或稱子音,在調音語音學中是語音的一類,與元音相對,發音的調音環節中氣流在調音器官某一部分受到完全或部分阻礙。

英語的「元音」和「輔音」分別相當於漢語拼音裡的「韻母」和「聲母」。單元音可比對單韻母、雙元音相當於複韻母。


聲音可分為 periodic 與 aperiodic ,就是有沒有週期性的差異

人類語言,不管是元音還是輔音,都要有一個音源(source)。

元音的音源來自聲帶,一班是 almost periodic,輔音的音源一半來自 constriction (ex: s ),由此產生 aperiodic 的 noise

periodic 的音分為兩種:簡單(ex: 正弦波)、複雜

元音的音源一般都是複雜的,也就是可以分解成好幾個簡單的波

有好幾個 components 組成的波,經過數學分解後,可產生多個 harmonic 諧波 (spectrum)

在很多 harmonics 諧波中,第一個稱為基頻,也就是 F0 (0號共振峰、1號諧波),其他的都是基頻的整數倍 (H1,H2,H3)

ex: F0/H1=100Hz, F2/H1=200Hz, F3/H1=300Hz


語音學中,要強調一件事情,可以在兩件事情中間,加上一小段停頓。


頻譜圖(Spectrum) 就是描述在某一時間點上,各個頻率的聲音分佈情況。頻譜圖只能描述某一時間點,不能表達一段時間的情況,所以把頻譜連續的畫到一張圖裡,就有了聲譜圖 (Spectrogram)。

Pitch listing and plotting in Excel

  1. 選取一個音檔,只顯示 Spectrum, Pitch,把 Intensity, Formant 關掉。畫面上是 spectrum 跟藍色線條 Pitch
  2. 選取某一個聲音區塊,點下面的 "sel" 放大該區塊的畫面

  1. 如果發現突然有一個點特別高,還有最前面,沒有聲音,但是卻有 pitch 點,都可能是 praat 誤判。最後輸出時,可將該點刪除,改用前後兩點的平均作為該點的值(內插法)。
  2. 選取畫面上需要的聲音區塊,點 Pitch -> Pitch listing,會列出每10ms 的 F0_Hz

  1. 將兩段語音的 pitching listing,複製到 excel 畫出折線圖


另一種方法是,在 Praat Objects 右邊 "Analyse periodicity" -> "to pitch",(這邊如果已經知道該語音的)pitch 上下界限,可以調整設定。然後 OK 產生 pitch object。然後就先標記一塊 draw area(藍色框框),就能 Draw 到 picture。

Duration Manipulation

在不影響前後的聲音的條件下,先決定想要調整的 duration 聲音區塊,然後在前後一點點時間點,設定一塊處理語音的限制區間,修改 duration。

  1. 在 Praat Objects 右邊的 Manipulate -> To Manipulate,用預設值,點 OK

  2. 先選取要處理 duration 的聲音區塊

  3. 首先放大到聲音區間的開始點。將 cursor 點到想要處理的起點。在選單 Dur -> Add duration point at cursor,畫面上就會產生一個紅點。然後再 Add duration point at...,將 小數點第三位由 3 改為 2。畫面上會出現另一個綠色點

  1. 用相同的步驟,到聲音區塊的終點。增加兩個 duration point

  2. 回到 Praat Objects 畫面,點 Extract duration tier,就會出現一個新的 duration tier object

  3. Save -> Save as text file,存成一個 text file

  4. 用 text editor 打開該檔案 (test2.DurationTier),可看到四個點。第 1,4 兩點不動,

    File type = "ooTextFile"
    Object class = "DurationTier"
    
    xmin = 0 
    xmax = 1.8870625 
    points: size = 4 
    points [1]:
        number = 0.38218997211642386 
        value = 1 
    points [2]:
        number = 0.38318997211642386 
        value = 0.9999999999999996 
    points [3]:
        number = 0.49353125000000003 
        value = 0.9999999999999996 
    points [4]:
        number = 0.49453125000000003 
        value = 1 
    

    把中間兩點的 value 改為 1.5 倍,修改時必須放大為一樣的倍數

    File type = "ooTextFile"
    Object class = "DurationTier"
    
    xmin = 0 
    xmax = 1.8870625 
    points: size = 4 
    points [1]:
        number = 0.38218997211642386 
        value = 1 
    points [2]:
        number = 0.38318997211642386 
        value = 1.5
    points [3]:
        number = 0.49353125000000003 
        value = 1.5
    points [4]:
        number = 0.49453125000000003 
        value = 1 
    

    存檔後

  5. 回到 Parrat Objects,刪除舊的 DurationTier, Open -> Open from file,載入修改後的 duration tier

  6. 選取 "Manupulation" 及 "Duration Tier",右邊會出現 "Replace duration tier" 按鈕

  7. View & Edit Manupulation,可看到被拉高的 duration

  1. 可實際聽聽看聲音是不是被拉長了。在 File -> Publish resynthesis。回到 Praat Object 會出現一個 "Sound fromManipulationEditor" 的聲音檔。在 Save -> Save as wav file 可存成另一個 wav file

Pitch Manipulation

  1. 在 Praat Objects 右邊的 Manipulate -> To Manipulate,用預設值,點 OK。會出現一個 Manipulation object。可先 View & Edit
  2. 可以直接拉動 pitch 的點去做調整。也可以匯出到一個 text file,直接用 text editor 修改
  3. 回到 Praat Object,點右邊的 "Extract pitch tier",會出現 PitchTier object。點上面的 Save -> Save as PitchTier spreadsheet file

  4. 用 text editor 打開會是這樣

    "ooTextFile"
    "PitchTier"
    0 1.8870625 143
    0.24353125  405.36076816599967
    0.25353124999999999 384.58128094973438
    0.26353124999999999 371.21591458911877
    0.27353125  367.63791485651495
    0.28353125000000001 368.6819886604992
    0.29353125000000002 368.89100487289591
    0.30353125000000003 367.44155207316203
    0.31353124999999998 365.30946486949387
    0.32353124999999999 362.17120060758612
    0.33353125  360.9426395082146
    0.34353125000000001 361.86527201551934
    0.35353125000000002 363.25320207521213
  5. 可直接修改後面 pitch 數值,再載入修改後的 PitchTier,然後回到 Praat Object,選取 "Manipulation" 及新的 PitchTier,"Replace pitch tier" 後,可得到修改後的 sound file

Scripting

ref:

Mietta's Scripts

praat scripts

This is a collection of Praat scripts, written, modified, or used by Will Styler

執行 praat script 就是在 praat 最上面的選單中,有個 Open praat script 的功能,選取該 script,然後上面的選單最後一個,Run 執行即可

會將 labels.txt 文字檔,填寫到 TextGrid object 的 intervals 的 label 裡面

# This script reads lines from a text file (called labels.txt and saved in the home directory)
# and adds them line by line as labels for intervals in a selected TextTier in the selected TextGrid object.
#
# You should check that the boundaries are correct before running the script.
# The script will jump over intervals labeled as "xxx". Use this marking if there are intervals that
# you will remove later.
# Hint: This tool is useful if you use the mark_pauses script before it! It is easy to check that the
# pause boundaries are in correct places, if you know what kind of content should be in the sound
# segments - e.g., read sentences.
#
# This script is distributed under the GNU General Public License.
# Mietta Lennes 25.1.2002
#
soundname$ = selected$ ("TextGrid", 1)
select TextGrid 'soundname$'
stringlength = 0
filelength = 0
firstnewline = 0
oldlabel$ = ""
newlabel$ = ""
form Label intervals in an IntervalTier from text file
comment Give the path of the text file containing the label lines:
sentence Filename /Users/zqi/Dropbox/BILD/MMN/psychopy/labels.txt
comment Which IntervalTier in the selected TextGrid do you want to label?
integer Tier_(index) 1 (= the first IntervalTier)
comment Which interval do we start labeling from?
integer Starting_interval_(index) 1 (= the first interval)
comment Do you want to overwrite old labels?
comment (Intervals previously marked with 'xxx' will be skipped despite this!)
boolean Overwrite 1
endform

if fileReadable (filename$)
numberOfIntervals = Get number of intervals... tier
if starting_interval > numberOfIntervals
exit There are not that many intervals in the IntervalTier!
endif
leftoverlength = 0
# Read the text file and put it to the string file$
file$ < 'filename$'
if file$ = ""
    exit The text file is empty.
endif
filelength = length (file$)
leftover$ = file$
# Loop through intervals from the selected interval on:
for interval from starting_interval to numberOfIntervals
oldlabel$ = Get label of interval... tier interval
if oldlabel$ <> "xxx"
# Here we read a line from the text file and put it to newlabel$:
firstnewline = index (leftover$, newline$)
newlabel$ = left$ (leftover$, (firstnewline - 1))
leftoverlength = length (leftover$)
leftover$ = right$ (leftover$, (leftoverlength - firstnewline))
# Then we check if the interval label is empty. If it is or if we decided to overwrite, 
# we add the new label we collected from the text file:
    if overwrite = 1
                Set interval text... tier interval 'newlabel$'
            elsif oldlabel$ = ""
              Set interval text... tier interval 'newlabel$'
            else 
                    exit Stopped labeling, will not overwrite old labels!
   endif
endif
endfor
else 
    exit The label text file 'filename$' does not exist where it should!
endif

限制要處理 long sound file (Open -> Open long sound file)

處理一個已經有 interval labels 的 sound file,將每個 textgrid 作為檔名,分割成多個 wav,可加上檔名的 prefix/suffix。通常如果是有多個人講的同一段文字,在存檔時,會將每個人的 id number 放在檔名 suffix,這樣就可以針對同一個單字,同時聽多個人的 wav,做分析判斷。

# This script saves each interval in the selected IntervalTier of a TextGrid to a separate WAV sound file.
# The source sound must be a LongSound object, and both the TextGrid and 
# the LongSound must have identical names and they have to be selected 
# before running the script.
# Files are named with the corresponding interval labels (plus a running index number when necessary).
#
# NOTE: You have to take care yourself that the interval labels do not contain forbidden characters!!!!
# 
# This script is distributed under the GNU General Public License.
# 8.3.2002 Mietta Lennes
#

form Save intervals to small WAV sound files
    comment Which IntervalTier in this TextGrid would you like to process?
    integer Tier 1
    comment Starting and ending at which interval? 
    integer Start_from 1
    integer End_at_(0=last) 0
    boolean Exclude_empty_labels 1
    boolean Exclude_intervals_labeled_as_xxx 1
    boolean Exclude_intervals_starting_with_dot_(.) 1
    comment Give a small margin for the files if you like:
    positive Margin_(seconds) 0.01
    comment Give the folder where to save the sound files:
    sentence Folder /Users/lennes/Demo/save_labeled_intervals/exported/
    comment Give an optional prefix for all filenames:
    sentence Prefix Test_
    comment Give an optional suffix for all filenames (.wav will be added anyway):
    sentence Suffix 
endform

gridname$ = selected$ ("TextGrid", 1)
soundname$ = selected$ ("LongSound", 1)
select TextGrid 'gridname$'
numberOfIntervals = Get number of intervals... tier
if start_from > numberOfIntervals
    exit There are not that many intervals in the IntervalTier!
endif
if end_at > numberOfIntervals
    end_at = numberOfIntervals
endif
if end_at = 0
    end_at = numberOfIntervals
endif

# Default values for variables
files = 0
intervalstart = 0
intervalend = 0
interval = 1
intname$ = ""
intervalfile$ = ""
endoffile = Get finishing time

# ask if the user wants to go through with saving all the files:
for interval from start_from to end_at
    xxx$ = Get label of interval... tier interval
    check = 0
    if xxx$ = "xxx" and exclude_intervals_labeled_as_xxx = 1
        check = 1
    endif
    if xxx$ = "" and exclude_empty_labels = 1
        check = 1
    endif
    if left$ (xxx$,1) = "." and exclude_intervals_starting_with_dot = 1
        check = 1
    endif
    if check = 0
       files = files + 1
    endif
endfor
interval = 1
pause 'files' sound files will be saved. Continue?

# Loop through all intervals in the selected tier of the TextGrid
for interval from start_from to end_at
    select TextGrid 'gridname$'
    intname$ = ""
    intname$ = Get label of interval... tier interval
    check = 0
    if intname$ = "xxx" and exclude_intervals_labeled_as_xxx = 1
        check = 1
    endif
    if intname$ = "" and exclude_empty_labels = 1
        check = 1
    endif
    if left$ (intname$,1) = "." and exclude_intervals_starting_with_dot = 1
        check = 1
    endif
    if check = 0
        intervalstart = Get starting point... tier interval
            if intervalstart > margin
                intervalstart = intervalstart - margin
            else
                intervalstart = 0
            endif
    
        intervalend = Get end point... tier interval
            if intervalend < endoffile - margin
                intervalend = intervalend + margin
            else
                intervalend = endoffile
            endif
    
        select LongSound 'soundname$'
        Extract part... intervalstart intervalend no
        filename$ = intname$
        intervalfile$ = "'folder$'" + "'prefix$'" + "'filename$'" + "'suffix$'" + ".wav"
        indexnumber = 0
        while fileReadable (intervalfile$)
            indexnumber = indexnumber + 1
            intervalfile$ = "'folder$'" + "'prefix$'" + "'filename$'" + "'suffix$''indexnumber'" + ".wav"
        endwhile
        Write to WAV file... 'intervalfile$'
        Remove
    endif
endfor
  • VOT (Voice onset time) tier

發聲起始時間(英語:Voice onset time,簡稱VOT),或譯為嗓音起始時間、濁音起始時間、聲帶震動起始時間、濁聲初起時、初濁。VOT的具體含義不完全與字面吻合,實際指某一輔音從除阻的一刻到聲帶開始震動,中間所經過的時間。

從 release -> 到 onset 所經過的時間

calculatesegmentdurations.praat

# This script will calculate the durations of all labeled segments in a TextGrid object.
# The results will be save in a text file, each line containing the label text and the 
# duration of the corresponding segment..
# A TextGrid object needs to be selected in the Object list.
#
# This script is distributed under the GNU General Public License.
# 12.3.2002 Mietta Lennes

# ask the user for the tier number
form Calculate durations of labeled segments
    comment Which tier of the TextGrid object would you like to analyse?
    integer Tier 1
    comment Where do you want to save the results?
    text textfile durations.txt
endform

# check how many intervals there are in the selected tier:
numberOfIntervals = Get number of intervals... tier

# loop through all the intervals
for interval from 1 to numberOfIntervals
    label$ = Get label of interval... tier interval
    # if the interval has some text as a label, then calculate the duration.
    if label$ <> ""
        start = Get starting point... tier interval
        end = Get end point... tier interval
        duration = end - start
        # append the label and the duration to the end of the text file, separated with a tab:      
        resultline$ = "'label$' 'duration''newline$'"
        fileappend "'textfile$'" 'resultline$'
    endif
endfor

Automatically open each .wav file in a folder, manually label intervals and rectify vocal pulse markings

References

PRAAT 使用手冊

praat wiki

結合Praat進行語音實驗的步驟

以Praat 語言分析軟體應用於華語語音教學法初探

[Phonetics] Praat的下載、教學、plug-in、script

熊子瑜「XIONG Ziyu」語音與言語科學重點實驗室

praat 語音軟體操作手冊

Lec15 Praat ─ 進階版

NCTU OCW 外國語文學系 賴郁雯老師 發音概論 The art of articulation

音色與聲譜圖

2019/12/16

SSL container formats

在處理 SSL 以及 TLS 的時候,常需要利用 openssl 或是 java 的 keytool 產生憑證,而憑證通常會存放在某種規格的檔案中,而且不同的 client 通常支援了不同的憑證格式,例如常見的 .crt .pem 等等,以下我們試著去了解一下這些存放憑證的檔案規格。

  • .csr

  1. 這是 Certificate Signing Request 的簡稱
  2. 實際上的格式是 RFC2986 定義的 PKCS10
  3. 裡面包含了所有詳細的憑證資料,例如 subject, organization, state
  4. 用在數位簽章

  • .pem

  1. 這是 Privacy Enhanced Email 的簡稱
  2. 定義在 RFC 1421 ~ 1424
  3. 這是一種 container format,通常只會存放 public certificate
  4. 可以存放整個 certificate chain,包含了 public key, private key 與 root certificates
  5. 這是一個失敗的 email 加密方法,但儲存憑證的格式卻有被廣泛使用
  6. Base64 encoded ACII files

  • .key

  1. 這是 .pem 格式的檔案,只會存放 private key
  2. 這是既定俗成的一個副檔名,並不是一種標準的檔案格式

  • .der .cer .crt

  1. Distinguished Encoding Rules 的簡稱
  2. 是一種 binary format of encoding a data value of any data types including nested data structures
  3. 是一種 ASN.1 的編碼規則
  4. 規格定義在 ITU-T X.690
  5. windows 預設會將憑證輸出為 .der 格式的檔案

  • .p7b .p7c

  1. 定義在 RFC 2315
  2. 存放 Certificates & Chain certificates,不包含 private key
  3. Base64 encoded ASCII files

  • .pkcs12 .pfx .p12

  1. 由 RSA 定義在 Public-Key Cryptography Standards 這個規格中
  2. 必須用一個密碼才能打開這個 container 檔案
  3. 裡面儲存了 public 與 private certificate pairs 憑證
  4. 跟 .pem 檔案不同,檔案本身就有用密碼加密
  5. 可利用以下這個指令將 .p12 檔案裡面的 public 與 private keys 轉換成 .pem

    openssl pkcs12 -in a.p12 -out a.pem -nodes
  6. 常用在 Windows OS,這是用來匯入或匯出 certificates and Private keys

  • .crl

  1. Certificate Revocation List 的簡稱
  2. CA (Certificate Authorities) 會在憑證過期前,產生出來,用來通知使用者這些憑證已經過期了

What is a Pem file and how does it differ from other OpenSSL Generated Key File Formats?

What are the differences between PEM, DER, P7B/PKCS#7, PFX/PKCS#12 certificates

2019/12/09

Scheme Tutorial 4

Defining Syntax

自訂語法稱為 macro。

macro 是程式碼的代換,程式碼在被求值或編譯前,先進行替換,然後再繼續執行。

scheme 可使用符合 R5RS 規範的 syntax-rules 定義 macro,這個方式比 Common Lisp 簡單,使用 syntax-rules 可直接定義 macro ,而不需要擔心 variable capture 的問題。但 scheme 如果要定義複雜的 macro 就比 Common Lisp 困難。

ex: 一個將變數賦值為'()的 macro

syntax-rules 中第二個參數是變換前和變化後的表達式的序對所構成的表。 _ 代表 macro 的名字。這個 macro 會讓 (nil! x)會變換為(set! x '())

(define-syntax nil!
  (syntax-rules ()
    ((_ x)
     (set! x '()))))

因為 closure 的問題,這種程式不能用函數來實作,函數不能影響外部變數。

(define (f-nil! x)
   (set! x '()))
(define a 1)
;Value: a

(f-nil! a)
;Value: 1

a
;Value: 1           ; the value of a dose not change

ex: 編寫 macro: when,當謂詞求值為真時,求值相應語句

... 代表任意數量的 expressions。

以下的程式,會將 (when pred b1 ...)變換為(if pred (begin b1 ...))

(define-syntax when
  (syntax-rules ()
    ((_ pred b1 ...)
     (if pred (begin b1 ...)))))

因為這個 macro 是將 expression 變換為 if,因此不能用函數來實作,以下是使用 when 的範例

(let ((i 0))
  (when (= i 0)
    (display "i == 0")
    (newline)))

i == 0
;Unspecified return value

ex: 編寫 macro: while, for

(define-syntax while
  (syntax-rules ()
    ((_ pred b1 ...)
     (let loop () (when pred b1 ... (loop))))))

(define-syntax for
  (syntax-rules ()
    ((_ (i from to) b1 ...)
     (let loop((i from))
       (when (< i to)
      b1 ...
      (loop (1+ i)))))))

使用

(let ((i 0))
  (while (< i 10)
    (display i)
    (display #\Space)
    (set! i (+ i 1))))
0 1 2 3 4 5 6 7 8 9
;Unspecified return value


(for (i 0 10)
  (display i)
  (display #\Space))
0 1 2 3 4 5 6 7 8 9
;Unspecified return value

ex: 編寫 when 的相反,當謂詞求值為假時執行相應的表達式

(define-syntax unless
  (syntax-rules ()
    ((_ pred b1 ...)
     (if (not pred)
     (begin
       b1 ...)))))

同時定義多個 macro 模式

incf 可讓變數數值增加,如果沒有增加數量的參數,就直接 +1

(define-syntax incf
  (syntax-rules ()
    ((_ x) (begin (set! x (+ x 1)) x))
    ((_ x i) (begin (set! x (+ x i)) x))))

(let ((i 0) (j 0))
  (incf i)
  (incf j 3)
  (display (list 'i '= i))
  (newline)
  (display (list 'j '= j)))
(i = 1)
(j = 3)
;Unspecified return value

ex: 編寫 decf

(define-syntax decf
  (syntax-rules ()
    ((_ x) (begin (set! x (- x 1)) x))
    ((_ x i) (begin (set! x (- x i)) x))))

ex: 改進 for,可接受參數 step size,如沒有該參數,step size 為 1

(define-syntax for
  (syntax-rules ()
    ((_ (i from to) b1 ...)
     (let loop((i from))
       (when (< i to)
      b1 ...
      (loop (1+ i)))))
                
    ((_ (i from to step) b1 ...)
     (let loop ((i from))
       (when (< i to)
      b1 ...
      (loop (+ i step)))))))

遞迴定義 macro

or 與 and 是透過遞迴定義

(define-syntax my-and
  (syntax-rules ()
    ((_) #t)
    ((_ e) e)
    ((_ e1 e2 ...)
     (if e1
     (my-and e2 ...)
     #f))))

(define-syntax my-or
  (syntax-rules ()
    ((_) #f)
    ((_ e) e)
    ((_ e1 e2 ...)
     (let ((t e1))
       (if t t (my-or e2 ...))))))

ex: 定義 let*

(define-syntax my-let*
  (syntax-rules ()
    ((_ ((p v)) b ...)
     (let ((p v)) b ...))
    ((_ ((p1 v1) (p2 v2) ...) b ...)
     (let ((p1 v1))
       (my-let* ((p2 v2) ...)
        b ...)))))

使用保留字

syntax-rule 的第一個參數是保留字的 list,例如 cond 的定義中, else 是保留字

(define-syntax my-cond
  (syntax-rules (else)
    ((_ (else e1 ...))
     (begin e1 ...))
    ((_ (e1 e2 ...))
     (when e1 e2 ...))
    ((_ (e1 e2 ...) c1 ...)
     (if e1 
     (begin e2 ...)
     (cond c1 ...)))))

local syntax

scheme 可使用 let-syntax, leterc-syntax 定義 local syntax,這種形式的用法跟 define-syntax 類似

相依於 macro 定義的實作

有些 macro 無法用 syntax-rules 實作,但在不同的 scheme implementation 裡面有其他定義這種 macro 的方法。例如 MIT-scheme 的 sc-macro-transformer,可讓使用者用跟 Common Lisp 相似的方法實作 macro,` 以及 ,@的要參考 Common Lisp HyperSpec

ex: show-vars用於顯示變數的值

(define-syntax show-vars
  (sc-macro-transformer
    (lambda (exp env)
      (let ((vars (cdr exp)))
           `(begin
              (display
                (list
                  ,@(map (lambda (v)
                            (let ((w (make-syntactic-closure env '() v)))
                                 `(list ',w ,w)))
                          vars)))
      (newline))))))

(let ((i 1) (j 3) (k 7))
  (show-vars i j k))
((i 1) (j 3) (k 7))
;Unspecified return value

ex: random-choice被用於從參數中隨機選擇一個值或者過程

(define-syntax random-choice
  (sc-macro-transformer
   (lambda (exp env)
     (let ((i -1))
       `(case (random ,(length (cdr exp)))
      ,@(map (lambda (x)
           `((,(incf i)) ,(make-syntactic-closure env '() x)))
         (cdr exp)))))))

(define (turn-right) 'right)
(define (turn-left) 'left)
(define (go-ahead) 'straight)
(define (stop) 'stop)

(random-choice (turn-right) (turn-left) (go-ahead) (stop))
;Value: right

這是展開的結果

(case (random 4)
  ((0) (turn-right))
  ((1) (turn-left))
  ((2) (go-ahead))
  ((3) (stop)))

ex: anaphoric macro,謂詞的結果可以被指為it。變量it被捕獲,以使得第二個參數make-syntactic-closure變為'(it)

(define-syntax aif
  (sc-macro-transformer
   (lambda (exp env)
     (let ((test (make-syntactic-closure env '(it) (second exp)))
       (cthen (make-syntactic-closure env '(it) (third exp)))
       (celse (if (pair? (cdddr exp))
              (make-syntactic-closure env '(it) (fourth exp))
              #f)))
       `(let ((it ,test))
      (if it ,cthen ,celse))))))

(let ((i 4))
  (aif (memv i '(2 4 6 8))
       (car it)))
;Value: 4

這是展開的結果

(let ((it (memv i '(2 4 6 8))))
  (if it
      (car it)
      #f))

Continuation

Continuation 這是 scheme 特有的資料型別,其他程式語言沒有實作這種資料型別。

Continuation 的一般定義

Continuation 是回到 Top Level 以前,所需要執行的運算。例如 (* 3 (+ 1 2)),在求值 (+ 1 2)後,應該計算{ (* 3 []) } 乘以3,但是大部分的程式語言都不支援這樣的語法。

Continuation-Passing-Style(CPS)

CPS 是一種 programming style,這會將目前函數結果的後續函數,作為參數傳給現在的函數。

ex: CPS style 的加法與乘法

(define (return x)
  x)

(define (k+ a b k)
  (k (+ a b)))

(define (k* a b k)
  (k (* a b)))

; 計算 (* 3 (+ 1 2))
(k+ 1 2 (lambda (x) (k* x 3 return)))

Scheme的普通形式中,值在括號內被計算並向括號外傳遞。但 CPS 與此相反,值向括號內傳遞。上面的例子中,k+(+ 1 2)的值傳遞給(lambda (x) (k* x 3 return)),而k*(* (+ 1 2) 3)的結果傳給return

以 CPS 方式撰寫遞迴函數

;;; normal factorial
(define (fact n)
  (if (= n 1)
      1
      (* n (fact (- n 1)))))

;;; CPS factorial
(define (kfact n k)
  (if (= n 1)
      (k 1)
      (kfact (- n 1) (lambda (x) (k (* n x))))))

; 3 + 4!
(+ 3 (fact 4))
;Value: 27

(kfact 4 (lambda (x) (k+ x 3 return)))
;Value: 27

ex: 用普通方式和CPS編寫計算表中元素之積的函數。在CPS函數中,後繼函數儲存在局部變量break中,因此當元素乘以0時,可以立即退出。

;;; normal
(define (product ls)
  (let loop ((ls ls) (acc 1))
    (cond
     ((null? ls) acc)
     ((zero? (car ls)) 0)
     (else (loop (cdr ls) (* (car ls) acc))))))

;;; CPS
(define (kproduct ls k)
  (let ((break k))
    (let loop ((ls ls) (k k))
      (cond
       ((null? ls) (k 1))
       ((zero? (car ls)) (break 0))
       (else (loop (cdr ls) (lambda (x) (k (* (car ls) x)))))))))

(+ 100 (product '(2 4 7)))
;Value: 156

(kproduct '(2 4 7) (lambda (x) (k+ x 100 return)))
;Value: 156

CPS 在這樣的例子中並不實用,但在 natural language parsing 與 logical programming 很有用。因 CPS 可靈活改變後續的過程。

exception handling

kproduct 的錯誤處理版本,當 list 出現非數字時,計算會終止

(define (non-number-value-error x)
  (display "Value error: ")
  (display  x)
  (display " is not number.")
  (newline)
  'error)

(define (kproduct ls k k-value-error)
  (let ((break k))
    (let loop ((ls ls) (k k))
      (cond
       ((null? ls) (k 1))
       ((not (number? (car ls))) (k-value-error (car ls)))
       ((zero? (car ls)) (break 0))
       (else (loop (cdr ls) (lambda (x) (k (* (car ls) x)))))))))


(kproduct '(2 4 7)
      (lambda (x) (k+ x 100 return))
      non-number-value-error)
;Value: 156

(kproduct '(2 4 7 hoge)
      (lambda (x) (k+ x 100 return))
      non-number-value-error)
Value error: hoge is not number.
;Value: error

Scheme 的 Continuation

Continuation 有以下特性

  1. 存在於整個計算過程中
  2. 函數式程序設計語言和CPS可以顯式地處理它

Scheme 將 Continuation 以 first class object 實作,這是普通的資料型別。任何時候都可以呼叫call-with-current-continuation。由於繼續是普通數據類型,你可以隨心所欲地重用。考慮到call-with-current-continuation名字過長,通常使用其縮名call/cc

(define call/cc call-with-current-continuation)

函數call-with-current-continuation (call/cc)接受一個參數。該參數是一個函數,函數的參數接收當前繼續。

; 沒有呼叫 continuation,跟一般 S-expression 一樣
(* 3 (call/cc (lambda (k) (+ 1 2))))
;Value: 9

; 有使用 continuation,參數跳過了 call/cc 的處理,escape 到 call/cc 的外面
; k是一個一元函數,等同於 (lambda (x) (* 3 x))
(* 3 (call/cc (lambda (k) (+ 1 (k 2)))))
;Value: 6

目前的 continuation 可以像其它數據類型那樣被儲存起來,並隨心所欲地重用。由於目前的 continuation 是回到頂層的處理過程,它的返回會忽略周圍的S-表達式

(define cc)
  (* 3 (call/cc (lambda (k)
                  (set! cc k)
                  (+ 1 2))))
  
;Value: 9

(+ 100 (cc 3))
;Value: 9

(+ 100 (cc 10))
;Value: 30

Throwing values using call/cc

要從一個計算過程中 esacpe,最簡單的方式是使用 call/cc。

ex: 從 tree 裡面搜尋 leaf 元素

(define (find-leaf obj tree)
  (call/cc
    (lambda (cc)
       (letrec ((iter
                   (lambda (tree)
                      (cond
                        ((null?  tree) #f)
                        ((pair? tree)
                           (iter (car tree))
                           (iter (cdr tree)))
                        (else
                          (if (eqv? obj tree)
                            (cc obj)))))))
         (iter tree)))))

(find-leaf 7 '(1 (2 3) 4 (5 (6 7))))
;Value: 7

(find-leaf 8 '(1 (2 3) 4 (5 (6 7))))
;Value: #f

ex: 支援 throw 的語法 block

(define-syntax block
  (syntax-rules ()
    ((_ tag e1 ...)
     (call-with-current-continuation
       (lambda (tag)
          e1 ...)))))

(block break
   (map (lambda (x)
           (if (positive? x)
           (sqrt x)
           (break x)))
    '(1 2 3)))
;Value: (1 1.4142135623730951 1.7320508075688772)

(block break
   (map (lambda (x)
           (if (positive? x)
           (sqrt x)
           (break x)))
    '(1 -2 3)))
;Value: -2

generator

如何用 call/cc 實作一個 tree generator,該 generator 以一個 tree 為參數,回傳一個 function,每次呼叫後會傳回後續的 leaves。

(define (leaf-generator tree)
  (let ((return '()))     ; 定義 local 變數 return
    (letrec ((continue    ; 用 letrec 定義 continue。continue 會將 leaf 回傳,把 continue 設定給 continue 並停止
      (lambda ()
        (let rec ((tree tree))                                      ; 用 rec 定義 named let
          (cond                                                     ; 用 cond 實現分支
           ((null? tree) 'skip)                                     ; 如果是空的 list,就不處理
           ((pair? tree) (rec (car tree)) (rec (cdr tree)))         ; 如果是序對,遞迴地將 car, cdr 設定給 rec
           (else                                                    ; 如果是 leaf
            (call/cc (lambda (lap-to-go)                            ; 呼叫 call/cc 取得目前狀態 lap-to-go
                   (set! continue (lambda () (lap-to-go 'restart))) ; 將目前狀態賦值給 continue。除了原本的 continue,lap-to-go 也包含目前的狀態。呼叫 lap-to-go 就是 (car tree)
                   (return tree))))))                               ; 函數將找到的 leaf 返回到呼叫函數的地方
        (return '()))))                                             ; 搜尋後,找不到,回傳空 list
    (lambda ()                                                  ; 回傳 leaf-generator 的生成器
      (call/cc (lambda (where-to-go)                            ; 呼叫 call/cc
                 (set! return where-to-go)                      ; 將返回值的目前狀態,賦值給 return
                 (continue)))))))



(define tr '((1 2) (3 (4 5))))
(define p (leaf-generator tr))

(p)
;Value: 1

(p)
;Value: 2

(p)
;Value: 3

(p)
;Value: 4

(p)
;Value: 5

(p)
;Value: ()

coroutine

因 continue 記錄了後續的計算過程,可用於多個工作同時執行的 coroutine

ex: 交替列印數字和字母

;;; abbreviation
(define call/cc call-with-current-continuation)

;;; 實作 queue 的部分
(define (make-queue)
  (cons '() '()))

(define (enqueue! queue obj)
  (let ((lobj (list obj)))
    (if (null? (car queue))
  (begin
    (set-car! queue lobj)
    (set-cdr! queue lobj))
  (begin
    (set-cdr! (cdr queue) lobj)
    (set-cdr! queue lobj)))
    (car queue)))

(define (dequeue! queue)
  (let ((obj (car (car queue))))
    (set-car! queue (cdr (car queue)))
    obj))


;;; 實作 coroutine
; 過程的queue
(define process-queue (make-queue))

; 在process-queue末尾添加thunk
(define (coroutine thunk)
  (enqueue! process-queue thunk))

; 取得process-queue的第一個過程並執行它
(define (start)
   ((dequeue! process-queue)))

; 將當前繼續添加到process-queue的末尾並執行隊列裡的第一個過程。這個函數將控制權交給另外一個coroutine。
(define (pause)
  (call/cc
   (lambda (k)
     (coroutine (lambda () (k #f)))
     (start))))


;;; example 如何使用
(coroutine (lambda ()
       (let loop ((i 0))
         (if (< i 10)
       (begin
         (display (1+ i))
         (display " ")
         (pause)
         (loop (1+ i)))))))

(coroutine (lambda ()
       (let loop ((i 0))
         (if (< i 10)
       (begin
         (display (integer->char (+ i 97)))
         (display " ")
         (pause)
         (loop (1+ i)))))))

(newline)
(start)


(load "coroutine.scm")

;Loading "test.scm"...
1 a 2 b 3 c 4 d 5 e 6 f 7 g 8 h 9 i 10 j
;... done
;Unspecified return value

Lazy evaluation

Lazy evaluation 是在需要時才進行求值的計算方式。

R5RS中定義支援 lazy evaluation 的函數

中間狀態被稱為延時對象(promise),它表示求值方法已經定義好了,但求值還未執行。

最終的值通過對延時對象(promise)呼叫 force 計算出來。

  • (delay proc)

    proc創建一個延時對象(promise)。

  • (promise? obj)

    如果obj是一個延時對象就返回 #t。

  • (force promise)

    對延時對象求值,執行求值操作。

ex: 延時對象(promise)透過對(1 + 2) 呼叫 delay產生,然後透過函數force對延時對象求值。

force 沒有副作用 side effect,因此可以重複使用 laz

(define laz (delay (+ 1 2)))
;Value: laz

laz
;Value 11: #[promise 11]

(promise? laz)
;Value: #t

(force laz)
;Value: 3

(* 10 (force laz))
;Value: 30

以 lazy evaluation 表示無窮數列

可用 lazy evaluation 來代表無窮數列。

無窮數列可用 cons cell () 處理,cons 部分透過強制求值 cdr 產生,可無限重複這個過程來產生無窮數列。

無窮數列的函數與 macro

lazy-map包含一個特殊delay構造用於lazy evaluation,所以它需要被定義為 macro

ex: 等差和等比數列分別被定義為(ari a0 d)(geo a0 r),其中a0dr分別是初始值,公差,公比。這些函數使用函數inf-seq定義。

;;;;  sequences

;;; infinite sequences represented by a_(n+1) = f(a_n)
(define (inf-seq a0 f)
  (lazy-cons a0 (inf-seq (f a0) f)))

;;; arithmetic sequence 等差數列
(define (ari a0 d)
  (inf-seq a0 (lambda (x) (+ x d))))

;;; geometric sequence 等比數列
(define (geo a0 r)
  (inf-seq a0 (lambda (x) (* x r))))

(define g1 (geo 1 2))
(head g1 10)
;Value 12: (1 2 4 8 16 32 64 128 256 512)

(define g2 (geo 1 (/ 1 2)))

(head g2 10)
;Value 13: (1 1/2 1/4 1/8 1/16 1/32 1/64 1/128 1/256 1/512)

(head (lazy-map * g1 g2) 10)
;Value 14: (1 1 1 1 1 1 1 1 1 1)

(define ar1 (ari 1 1))
;;Value: ar1

(head ar1 10)
;;Value 15: (1 2 3 4 5 6 7 8 9 10)

(head (lazy-filter even? ar1) 10)
;;Value 16: (2 4 6 8 10 12 14 16 18 20)

ex: 費伯納西數列

fib(1) = 1
fib(2) = 1
fib(n+1) = fib(n) + fib(n-1)
(define fib
  (lazy-cons 1
             (lazy-cons 1
                        (lazy-map + fib (lazy-cdr fib)))))

(head fib 20)
;Value 5: (1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765)

(lazy-ref fib 100)

;Value: 573147844013817084101

ex: 牛頓法求平方根

a(n+1) =  (a(n) + N/a(n)) / 2

a =  (a +  N/a) / 2
⇒
      2a = a +  N/a
      a =  N/a
      a*a = N
      a =  √N
;;; Newton-Raphson method
(define (newton-raphson n)
  (inf-seq 1 (lambda (x) (/ (+ x (/ n x)) 2))))

;;; returning a reasonable answer.
;;; If the ratio of successive terms is in (1 - eps) and (1 + eps),
;;; or the following term is zero,
;;; the function returns it.
(define (lazylist->answer ls eps)
  (let ((e1 (- 1.0 eps))
        (e2 (+ 1.0 eps)))
    (let loop ((val (lazy-car ls))
               (ls1 (lazy-cdr ls)))
      (let ((val2 (lazy-car ls1)))
        (if  (or (zero? val2) (< e1 (/ val val2) e2))
            (exact->inexact val2)
          (loop val2 (lazy-cdr ls1)))))))

;;;
(define (my-sqrt n eps)
  (lazylist->answer (newton-raphson n) eps))

; 在相對誤差eps下,計算n的平方根
(my-sqrt 9 0.0000001)
; Value: 3.

Nondeterminism 不確定性

Nondeterminism 是一種透過定義問題來解決問題的方法。不確定性程式自動選擇符合條件的選項。這項技術很適合邏輯編程。

ex: 以下代碼返回一對數,其和是一個質數。其中一個數從'(4 6 7)選取,另一個從'(5 8 11)選取。

;;; abbreviation for call-with-current-continuation
(define call/cc call-with-current-continuation)

;;; This function is re-assigned in `choose' and `fail' itself.
(define fail #f)

(define (prime? n)
  (let ((m (sqrt n)))
    (let loop ((i 2))
      (or (< m i)
          (and (not (zero? (modulo n i)))
               (loop (+ i (if (= i 2) 1 2))))))))


(define-syntax amb
  (sc-macro-transformer
   (lambda (exp env)
     (if (null? (cdr exp))
         `(fail)
       `(let ((fail0 fail))
          (call/cc
           (lambda (cc)
             (set! fail
                   (lambda ()
                     (set! fail fail0)
                     (cc (amb ,@(map (lambda (x)
                                       (make-syntactic-closure env '() x))
                                     (cddr exp))))))
             (cc ,(make-syntactic-closure env '() (second exp))))))))))

(let ((i (amb 4 6 7))
      (j (amb 5 8 11)))
  (if (prime? (+ i j))
      (list i j)
      (amb)))

;Value 23: (6 5)

(amb 4 6 7) 從4,6和7中返回一個合適的數,(amb 5 8 11)從5,8和11中返回一個合適的數。如果沒有選出合適的值,(amb)返回假。

ex: 邏輯編程

五位女同學參加一場考試。她們的家長對考試結果過分關心。為此她們約定,在給家裡寫信談到考試時,每個姑娘都要寫一句真話和一句假話。下面是從她們的信中摘出的句子:

貝蒂:“凱迪考第二,我只考了第三。” 艾賽爾:“你們應該高興地聽到我考了第一,瓊第二。” 瓊:“我考第三,可憐的艾賽爾考得最差。” 凱蒂:“我第二,瑪麗只考了第四。” 瑪麗:“我是第四,貝蒂的成績最高。”

這五位同學的實際排名是什麼?

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;      Nondeterminsm usint macro amb
;;;      T.Shido
;;;      November 15, 2005
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; abbreviation for call-with-current-continuation
(define call/cc call-with-current-continuation)

;;; This function is re-assigned in `choose' and `fail' itself.
(define fail #f)


;;; nondeterminsm macro operator
(define-syntax amb
  (syntax-rules ()
    ((_) (fail))
    ((_ a) a)
    ((_ a b ...)
     (let ((fail0 fail))
       (call/cc
    (lambda (cc)
      (set! fail
        (lambda ()
          (set! fail fail0)
          (cc (amb b ...))))
      (cc a)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; for MIT-Scheme only
; use it if you don't like warning during compilation
; (define-syntax amb
;   (sc-macro-transformer
;    (lambda (exp env)
;      (if (null? (cdr exp))
;          `(fail)
;        `(let ((fail0 fail))
;           (call/cc
;            (lambda (cc)
;              (set! fail
;                    (lambda ()
;                      (set! fail fail0)
;                      (cc (amb ,@(map (lambda (x)
;                                        (make-syntactic-closure env '() x))
;                                      (cddr exp))))))
;              (cc ,(make-syntactic-closure env '() (second exp))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; function for nondeterminsm
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (define (choose . ls)
;   (if (null? ls)
;       (fail)
;     (let ((fail0 fail))
;       (call/cc
;        (lambda (cc)
;          (begin
;           (set! fail
;                 (lambda ()
;                   (set! fail fail0)
;                   (cc (apply choose (cdr ls)))))
;           (cc (car ls))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; returning all possibilities
(define-syntax set-of
  (syntax-rules ()
    ((_ s)
      (let ((acc '()))
        (amb (let ((v s))
               (set! acc (cons v acc))
               (fail))
             (reverse! acc))))))

;;; if not pred backtrack
(define (assert pred)
  (or pred (amb)))

;;; returns arbitrary number larger or equal to n
(define (an-integer-starting-from n)
  (amb n (an-integer-starting-from (1+ n))))

;;; returns arbitrary number between a and b
(define (number-between a b)
  (let loop ((i a))
    (if (> i b)
        (amb)
      (amb i (loop (1+ i))))))


;;; small functions for SICP Exercise 4.42
(define (xor a b)
  (if a (not b) b))

(define (all-different? . ls)
  (let loop ((obj (car ls)) (ls (cdr ls)))
    (or (null? ls)
        (and (not (memv obj ls))
             (loop (car ls) (cdr ls))))))

;;; SICP Exercise 4.42
(define (girls-exam)
  (let ((kitty (number-between 1 5))
        (betty (number-between 1 5)))
    (assert (xor (= kitty 2) (= betty 3)))
    (let ((mary (number-between 1 5)))
      (assert (xor (= kitty 2) (= mary 4)))
      (assert (xor (= mary 4) (= betty 1)))
      (let ((ethel (number-between 1 5))
            (joan (number-between 1 5)))
        (assert (xor (= ethel 1) (= joan 2)))
        (assert (xor (= joan 3) (= ethel 5)))
        (assert (all-different? kitty betty ethel joan mary))
        (map list '(kitty betty ethel joan mary) (list kitty betty ethel joan mary))))))

;;; Bad answer for ex 4.42
(define (girls-exam-x)
  (let ((kitty (number-between 1 5))
        (betty (number-between 1 5))
        (mary (number-between 1 5))
        (ethel (number-between 1 5))
        (joan (number-between 1 5)))
    (assert (xor (= kitty 2) (= betty 3)))
    (assert (xor (= kitty 2) (= mary 4)))
    (assert (xor (= mary 4) (= betty 1)))
    (assert (xor (= ethel 1) (= joan 2)))
    (assert (xor (= joan 3) (= ethel 5)))
    (assert (all-different? kitty betty ethel joan mary))
    (map list '(kitty betty ethel joan mary) (list kitty betty ethel joan mary))))


;;; to show cpu time
(define-syntax cpu-time/sec
  (syntax-rules ()
    ((_ s)
     (with-timings
     (lambda () s)
       (lambda (run-time gc-time real-time)
     (write (internal-time/ticks->seconds run-time))
     (write-char #\space)
     (write (internal-time/ticks->seconds gc-time))
     (write-char #\space)
     (write (internal-time/ticks->seconds real-time))
     (newline))))))


;;; initializing fail
(call/cc
 (lambda (cc)
   (set! fail
         (lambda ()
           (cc 'no-choise)))))



(cpu-time/sec (girls-exam))
.01 0. .021
;Value 2: ((kitty 1) (betty 3) (ethel 5) (joan 2) (mary 4))

(cpu-time/sec (girls-exam-x))
.13 0. .203
;Value 3: ((kitty 1) (betty 3) (ethel 5) (joan 2) (mary 4))

References

mit-scheme user doc

Yet Another Scheme Tutorial 中文版

Yet Another Scheme Tutorial

2019/12/02

Scheme Tutorial 3

Input/Output

瞭解如何讀寫檔案

Input from Files 自檔案輸入

open-input-file,read-char和eof-object?

(open-input-file filename) 可打開一個文件,回傳 a port of file。

(read-char port)用於從port中讀取一個 char。當讀取到文件結尾(EOF)時,此函數返回eof-object,可以使用eof-object?來檢查。

(close-input-port port)用於關閉輸入 port。

ex: 實作以字符串形式回傳文件內容的函數

(define (read-file file-name)
  (let ((p (open-input-file file-name)))
    (let loop((ls1 '()) (c (read-char p)))
      (if (eof-object? c)
        (begin
          (close-input-port p)
          (list->string (reverse ls1)))
        (loop (cons c ls1) (read-char p)) ))))

(read-file "hello.txt")

begin 是一個集合多個 expression 的語法,當原本的語法中,只能放一個 form/expression 時,就用 begin 包裝多個 form/expression

ex: 每次使用 y 都會加上 1

(+ x 
   (begin (set! y (+ y 1)) y) 
   z)
call-with-input-file, with-input-from-file

(call-with-input-file filename procedure)

將 filename 文件打開後,提供輸入,procedure 接受 input port 為參數,因文件可能會再被使用,procedure 結束後,不會自動關閉 port,必須自己呼叫 (close-input-port p)

(define (read-file file-name)
  (call-with-input-file file-name
    (lambda (p)
      (let loop((ls1 '()) (c (read-char p)))
         (if (eof-object? c)
            (begin
              (close-input-port p)
              (list->string (reverse ls1)))
         (loop (cons c ls1) (read-char p))) ))))

如果是使用 with-input-from-file ,會自動關閉 port

(define (read-file file-name)
  (with-input-from-file file-name
    (lambda ()
      (let loop((ls1 '()) (c (read-char)))
        (if (eof-object? c)
          (list->string (reverse ls1))
        (loop (cons c ls1) (read-char)))) )))
read

(read port) 可從 port 讀取 S-expression

ex: paren.txt

'(Hello world!
Scheme is an elegant programming language.)

'(Lisp is a programming language ready to evolve.)
(define (s-read file-name)
  (with-input-from-file file-name
    (lambda ()
      (let loop ((ls1 '()) (s (read)))
        (if (eof-object? s)
          (reverse ls1)
        (loop (cons s ls1) (read)))) )))


(s-read "paren.txt")
;Value 2: ((quote (hello world! scheme is an elegant programming language.)) (quote (lisp is a programming language ready to evolve.)))

ex:

編寫函數(read-lines),該函數返回一個由字符串構成的表,分別代表每一行的內容。在Scheme中,換行符是由#\Linefeed表示。下面展示了將該函數用於 hello.txt 的結果。 (read-lines "hello.txt") ⇒ ("Hello world!" "Scheme is an elegant programming language.")

(define (group-list ls sep)
  (letrec ((iter (lambda (ls0 ls1)
       (cond
        ((null? ls0) (list ls1))
        ((eqv? (car ls0) sep)
         (cons ls1 (iter (cdr ls0) '())))
        (else (iter (cdr ls0) (cons (car ls0) ls1)))))))
    (map reverse (iter ls '())) ))


(define (read-lines file-name)
  (with-input-from-file file-name
    (lambda ()
      (let loop((ls1 '()) (c (read-char)))
        (if (eof-object? c)
          (map list->string (group-list (reverse ls1) #\Linefeed))  ; *
        (loop (cons c ls1) (read-char)))) )))


(group-list '(1 4 0 3 7 2 0 9 5 0 0 1 2 3) 0)
;Value 3: ((1 4) (3 7 2) (9 5) () (1 2 3))

(read-lines "hello.txt")
;Value 4: ("Hello world!" "Scheme is an elegant programming language.")

Output to files 輸出到檔案

打開用來輸出資料的 port

(open-output-file filename)
打開一個文件用作輸出,取得該輸出的 port

(close-output-port port)
關閉用於輸出的port

(call-with-output-file filename procedure)
打開文件filename用於輸出,並呼叫 procedure。該函數以輸出的 port 為參數。

(with-output-to-file filename procedure)
打開文件filename作為標準輸出,並呼叫 procedure。該 procedure 沒有參數。當控制權從過程procedure中返回時,文件會自動被關閉。

用來輸出的函數

(write obj port)
該函數將obj輸出至port。字串被雙引號括起而字符具有前綴 #\ 。

(display obj port)
該函數將obj輸出至port。字串不被雙引號括起而字符不具有前綴#\。

(newline port)
以新行起始。

(write-char char port)
該函數向port寫入一個 char。

ex: 編寫函數(my-copy-file)實現拷貝文件

(define (my-copy-file from to)
  (let ((pfr (open-input-file from))
        (pto (open-output-file to)))
    (let loop((c (read-char pfr)))
      (if (eof-object? c)
        (begin
          (close-input-port pfr)
          (close-output-port pto))
        (begin
          (write-char c pto)
          (loop (read-char pfr)) ))) ))

ex: 編寫函數(print-line),該函數具有任意多的字串作為參數,並將它們輸出至標準輸出。輸出的字串應該用新行分隔。

(define (print-lines . lines)
  (let loop((ls0 lines))
    (if (pair? ls0)
        (begin
         (display (car ls0))
         (newline)
         (loop (cdr ls0))) ) ))

Assignment 賦值

在 scheme 不常用 assignment,濫用 assignment 會讓程式碼很難懂,除非不得已,否則不要使用 assignment。

某些特別的演算法需要 assignment 語法,例如 internal states 及 continuations

雖然 assignment 語法很常見,容易理解,但卻有些缺陷,因為 assignment 改變了參數的值,具有破壞性。R5RS 中定義 assignment 為 set!set-car!set-cdr!string-set!vector-set!,在 scheme 所有具有破壞性的保留字都是以 ! 結尾。

set!

使用前,該參數要先被定義。跟 Common Lisp 不同,set! 無法給一個 S-expression 賦值。

(define var 1)
(set! var (* var 10))
var
;Value: 10

(let ((i 1))
    (set! i (+ i 3))
    i)
;Value: 4

internal states

scheme 的變數作用範圍,限制在原始程式碼中的括號裡面,稱為 lexical closure 或 static scope。另外有一種稱為 dynamic scope,會在執行時動態決定作用範圍,目前已經沒有使用。

特殊形式 let, lambda, leterc 會產生 closure,lambda expression 的參數只在函數定義內部有效。

另外可使用 lexical closure 實現帶有 internal state 的 process,例如,模擬銀行帳戶存款/提款。

(define bank-account
  (let ((balance 10))
    (lambda (n)
      (set! balance (+ balance n))
      balance) ))


(bank-account -5)
;Value: 5

(bank-account -1)
;Value: 4

只要稍微修改一下,就可以實現多個帳戶

(define (make-bank-account balance)
  (lambda (n)
    (set! balance (+ balance n))
    balance))

;Gates makes a bank account by donating  10 dollars
(define gates-bank-account (make-bank-account 10))
;Value: gates-bank-account

; donating 50 dollars
(gates-bank-account 50)
;Value: 60

; withdrawing 55 dollars
(gates-bank-account -55)
;Value: 5


; Torvalds makes a bank account by donating 100 dollars
(define torvalds-bank-account (make-bank-account 100))
;Value: torvalds-bank-account

; withdrawing 70 dollars
(torvalds-bank-account -70)
;Value: 30

; donating 300 dollars
(torvalds-bank-account 300)
;Value: 330

scheme procedure 會回傳一個 value,其他的用途就稱為 side effect,而 assignment 與 IO 就是一種 side effect。

ex: 修改 make-bank-account,提款超過 balance 時,會發生 error

(define (make-bank-account amount)
  (lambda (n)
    (let ((m (+ amount n)))
      (if (negative? m)
        'error
        (begin
          (set! amount m)
           amount)) )))

list 的破壞性操作 set-car! set-cdr

set-car!set-cdr 分別為一個 cons 單元的 car 與 cdr 部分設定新的值,跟 set!不同,這兩個函數可以為 S-expression 賦值。

(define tree '((1 2) (3 4 5) (6 7 8 9)))

; 把 1 改成 100
(set-car! (car tree) 100)

tree
; ((100 2) (3 4 5) (6 7 8 9))

;把 '(7 8 9) 改為 '(a b c)
(set-cdr! (third tree) '(a b c))

tree
; ((100 2) (3 4 5) (6 a b c))

queue

queue 是一種 FIFO 資料結構,list 則是 FILO。

以下是 queue 的資料結構

這是 enqueue 操作

  1. 將最後一個 cons 單元的 cdr 部分,指向新的元素
  2. 將 cons-cell-top 的 cdr 部分指向新的元素

這是 dequeue 操作

  1. 將queue head 元素存在 local 變數中
  2. 將 cons-cell-top 的 car 部分指向第二個元素

(define (make-queue)
  (cons '() '()))

(define (enqueue! queue obj)
  (let ((lobj (cons obj '())))
    (if (null? (car queue))
      (begin
        (set-car! queue lobj)
        (set-cdr! queue lobj))
      (begin
        (set-cdr! (cdr queue) lobj)
        (set-cdr! queue lobj)) )
    (car queue)))

(define (dequeue! queue)
  (let ((obj (car (car queue))))
    (set-car! queue (cdr (car queue)))
    obj))


(define q (make-queue))
;Value: q

(enqueue! q 'a)
;Value 12: (a)

(enqueue! q 'b)
;Value 12: (a b)

(enqueue! q 'c)
;Value 12: (a b c)

(dequeue! q)
;Value: a

q
;Value 13: ((b c) c)

char

在某個 char 前面加上 #\ 就表示它是 char,例如 #\a 表示 a

#\Space#\Tab#\Linefeed#\Return分別代表空格(Space)、製表符(Tab),Linefeed和返回(Return)

R5RS中定義了下面的與 char 相關的函數。

  • (char? obj)

    如果obj是一個 char 則返回#t

  • (char=? c1 c3)

    如果c1c2是同一個 char 的話則返回#t

  • (char->integer c)

    c轉化為對應的整數( char 代碼,character code)。

    ex:(char->integer #\a) => 97

  • (integer->char n)

    該函數將一個整數轉化為對應的字符。

  • (char<? c1 c2)(char<= c1 c2)(char> c1 c2)(char>= c1 c2)

    這些函數用於比較 char 。實際上,這些函數比較的是 char 代碼的大小。

    例如,(char<? c1 c2)等同於(< (char->integer c1) (char->integer c2))

  • (char-ci=? c1 c2)(char-ci<? c1 c2)(char-ci<=? c1 c2)(char-ci>? c1 c2)(char-ci>=? c1 c2)

    這些是 case-insensitive 比較函數

  • (char-alphabetic? c)(char-numeric? c)(char-whitespace? c)(char-upper-case? c)(char-lower-case? c)

    這些函數分別用於檢測 c是否為字母、數字、空白、大寫字母或小寫字母。

  • (char-upcase c)(char-downcase c)

    這些函數分別返回 c 對應的大寫或小寫。

string

用雙引號框住的就是字串

  • (string? s)

    如果s是一個字串則返回#t

  • (make-string n c)

    返回由n個 c 組成的字串。參數c 為 optional。

  • (string-length s)

    返回字串s的長度。

  • (string=? s1 s2)

    如果字串s1s2相同的話則返回#t

  • (string-ref s idx)

    返回字串s中索引為idx的 char(索引從0開始計數)。

  • (string-set! s idx c)

    將字符=串s中索引為idx的char設置為c

  • (substring s start end)

    返回字串sstart開始到end-1處的子字串。例如(substring "abcdefg" 1 4) => "b c d"

  • (string-append s1 s2 ...)

    連接兩個字串s1s2

  • (string->list s)

    將字串s轉換為由字符構成的表。

  • (list->string ls)

    將一個由 char 構成的表轉換為字串。

  • (string-copy s)

    複製字串s

ex: 編寫函數 title-style,讓每個單字的首字母大寫

先將 string 轉為 list,把空格後面的字元大寫,再轉回 string

(define (identity x) x)

(define (title-style str)
  (let loop ((ls (string->list str))
         (w #t)
         (acc '()))
    (if (null? ls)
    (list->string (reverse acc))
    (let ((c (car ls)))
      (loop (cdr ls)
        (char-whitespace? c)
        (cons ((if w char-upcase identity) c) acc))))))

;;; Another answer, You can assign caps to the string.
(define (title-style str)
  (let ((n (string-length str)))
    (let loop ((w #t) (i 0))
      (if (= i n)
      str
      (let ((c (string-ref str i)))
        (if w (string-set! str i (char-upcase c)))
        (loop (char-whitespace? c) (1+ i)))))))

(title-style "the cathedral and the bazaar")

symbol

透過 address 管理 string 的資料,symbol 可以被類似 eq? 這樣的函數快速處理,但 string 只能用 equal? 處理,因為 symbol 可被快速比較,常用來作 hash 的 key

以下是跟 symbol 有關的函數

  • (symbol? x)

    如果x是一個符號則返回#t。

  • (string->symbol str)

    str轉換為符號。str應該都是小寫的,否則地址系統可能無法正常運作。在MIT-Scheme中,(string->symbol "Hello")'Hello是不同的。

    (eq? (string->symbol "Hello") 'Hello)
    ;Value: ()
    
    (eq? (string->symbol "Hello") (string->symbol "Hello"))
    ;Value: #t
    
    (symbol->string  (string->symbol "Hello"))
    ;Value: "Hello"
  • (symbol->string sym)

    sym轉換為 string。

ex: 統計文章中的單字數量 wc.scm,裡面有用到 hash table 及 association list

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;   wc.scm
;;;   a scheme word-count program
;;;
;;;    by T.Shido
;;;    on August 19, 2005
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; 將 list of chars (ls0) 轉為 symbol
(define (list->symbol ls0)
  (string->symbol (list->string (reverse! ls0))))

; 檢查 c 是否在 list (ls) 裡面,如果有,就回傳 #t
(define (char-in c . ls)
  (let loop((ls0 ls))
    (if (null? ls0)
        #f
      (or (char=? c (car ls0))
          (loop (cdr ls0))))))

; 讀入 fname 檔案,回傳 list of symbols,這個函數會將大寫轉為小寫,並轉會 list of chars(w) 為 symbol,同時添加在 list of symbols (wls) 裡面
(define (read-words fname)
  (with-input-from-file fname
    (lambda ()
      (let loop((w '()) (wls '()))
        (let ((c (read-char)))
          (cond
           ((eof-object? c)
            (reverse! (if (pair? w)
                          (cons (list->symbol w) wls)
                       wls)))
           ((char-in c #\Space #\Linefeed #\Tab #\, #\.  #\ #\( #\) #\= #\? #\! #\; #\:)
            (loop '() (if (pair? w)
                          (cons (list->symbol w) wls)
                        wls)))
       (else
        (loop (cons (char-downcase c) w) wls))))))))

; sorting al,依照出現的頻率
(define (sort-by-frequency al)
  (sort al (lambda (x y) (> (cdr x) (cdr y)))))

; 讀入檔案 fname,回傳 a sorted association list by frequency in descending order
(define (wc fname)
  (let ((wh (make-eq-hash-table)))
    (let loop((ls (read-words fname)))
      (if (null? ls)
          (sort-by-frequency (hash-table->alist wh))
        (begin
         (hash-table/put! wh (car ls) (1+ (hash-table/get wh (car ls) 0)))
         (loop (cdr ls)))))))

Association List and Hash table

資料關聯是用 key , value 組成的 data pair,value 可由唯一的 key 決定。

association list

symbol, string, 數字 常被用來當作 key

'((hi . 3) (everybody . 5) (nice . 3) (to . 10) (meet . 4) (you . 8))
'((1 2 3) (4 5 6) (7 8 9))

assq, assv, assc 可從 association list 中搜尋某一項,如果找到 pair 的 car 等於給定的 key,就回傳該 data pair,找不到就回傳 #f。這些函數分別是使用 eq?, eqv?, equal? ,這表示 assq 速度最快。string, vector, list 應該轉換為 symbol 再當做 key,會提高程式效能。

(define wc '((hi . 3) (everybody . 5) (nice . 3) (to . 10) (meet . 4) (you . 8)))
;Value: wc

(assq 'hi wc)
;Value 2: (hi . 3)

(assq 'you wc)
;Value 3: (you . 8)

(assq 'i wc)
;Value: #f

(define n '((1 2 3) (4 5 6) (7 8 9)))
;Value: n

(assv 1 n)
;Value 4: (1 2 3)

(assv 8 n)
;Value: #f

hash table

hash table 會將 key 轉成整數,將值存放在該整數指到的位置。search, insert, delete 都可在 O(1) 完成

  • (make-eq-hash-table size), (make-eqv-hash-table size), (make-equal-hash-table size), (make-string-hash-table size)

    產生 hash table 的函數,分別是使用eq?eqv?equal?,和string=?比較 key 的值。hash table 的初始 size 是 optional。由於只比較 key 的 address,所以 eq-hash-table是最快的。且由於鍵是序列,所以equal-hash-tablestring-hash-table比較慢。

  • (hash-table/put! hash-table key datum)

    hash-tablekey對應的值設為datum

  • (hash-table/get hash-table key default)

    返回hash-table中的key對應的值。如果key不存在於hash-table中,返回default

  • (hash-table->alist hash-table)

    hash-table轉換為 association list。

ex: 產生密碼

stat-spell.scm

; 可閱讀英文句子,將資料儲存在 hash table,轉換為 association list 並儲存在 stat-spell.data 文件裡面
;;; make an alist of probable spelling from a given english text

; 如果 c 不是圖像 char 或者c是 #\:, #\;, #\', or #\",就返回#t。讀取英文句子時,這些 char 會被跳過。
(define (skip-char? c)
  (or (not (char-graphic? c)) (memv c '(#\: #\; #\' #\" #\`))))

; 有兩個參數;字元的頻率的關聯表(alist)和字元(c)。如果c在alist中,在序對的cdr部分增加一。如果不在,返回 (cons (cons c 1) alist)
(define (ss-make-alist c alist)
  (let ((p (assv c alist)))
    (if p
        (begin
         (set-cdr! p (1+ (cdr p)))
         alist)
      (cons (cons c 1) alist))))

; 由 filename 檔案中讀取 char,使用下一個 char 的出現頻率的 association list,來記錄這些字元
; stat-speel.dat 儲存結果類似:
; (#\v (#\y . 1) (#\a . 3) (#\o . 7) (#\e . 51) (#\i . 15))
; 表示 #\y, #\a, #\o, #\e, 和 #\i 跟隨 #\v 之後出現的次數分別是1, 3, 7, 51, 和15次
(define (ss-make-dat filename)
  (let ((char-hash (make-eqv-hash-table)))
    (with-input-from-file filename
      (lambda ()
    (let loop ((c #\Space))
      (let ((c1 (read-char)))
                 (if (not (eof-object? c1))
                     (if (skip-char? c1)
                         (loop c)
                         (let ((c1 (char-downcase c1)))
               (hash-table/put! char-hash c
                        (ss-make-alist c1 (hash-table/get char-hash c '())))
               (loop c1))))))))
    (with-output-to-file "stat-spell.dat"
      (lambda ()
    (display "(define *stat-spell* \'(")
    (newline)
    (let loop ((alst (sort (hash-table->alist char-hash)
                   (lambda (x y) (char<? (car x) (car y))))))
      (if (pair? alst)
          (begin
        (write (car alst))
        (newline)
        (loop (cdr alst)))))
        (display "))")
        (newline)))))

make-pw.scm

;;; make password from the alist of probable spelling
; 基於 stat-spell.dat 頻率數據產生由9到13個隨機字符組成字串表。#\Space 被添加在表結尾。
; 添加一個00到99之間的隨機數在隨機選取的字符串表的結尾。
; 隨機地將 #\Space 轉換為 #-, #_, #\/, #\Space, #., 或者 #\,。
; 隨機地將30%的字母字符變為大寫。

(load "stat-spell.dat") ; *stat-spell* (alist for following characters) is in.

(define (alist->hash al mode)
  (let ((h (case mode
             ((eq) (make-eq-hash-table))
             ((eqv) (make-eqv-hash-table))
             ((equal) (make-equal-hash-table))
             ((string) (make-string-hash-table)))))
    (for-each (lambda (p)
                (hash-table/put! h (car p) (cdr p)))
              al)
    h))

(define *stat-spell-hash* (alist->hash *stat-spell* 'eqv))

(define (pw-random-select vec)
  (vector-ref vec (random (vector-length vec))))

(define (random00)
  (let loop ((i 0) (acc '()))
    (if (= i 2)
        (list->string acc)
      (loop (1+ i) (cons (pw-random-select '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) acc)))))

(define (occasional-upcase c)
  (if (< (random 10) 3)
      (char-upcase c)
    c))

(define (pw-enhance ls)
  (list->string
   (map (lambda (c)
          (cond
           ((char=? c #\Space)
            (pw-random-select  '#(#\- #\_ #\/  #\Space  #\. #\, #\@ #\? #\( #\))))
           ((char-alphabetic? c)
            (occasional-upcase c))
           (else c)))
        (cdr (reverse! ls)))))


(define (random-following alist)
  (let ((n (random (apply + (map cdr alist)))))
    (let loop ((j 0) (alist alist))
      (if (pair? alist)
      (let* ((pair (car alist))
         (k (+ j (cdr pair))))
        (if (> k n)
        (car pair)
        (loop k (cdr alist))))))))

(define (make-pw h n)
  (let loop ((i 0) (c #\Space) (acc '()))
    (if (= i n)
        (string-append
         (pw-enhance (cons #\Space (cons c acc)))
         (random00))
      (loop (1+ i)
        (random-following (hash-table/get h c '((#\Space . 1))))
        (cons c acc)))))

(define (pw-candidates)
  (let loop ((i 0))
    (if (< i 10)
        (begin
         (display i)
         (display ": ")
         (write (make-pw *stat-spell-hash* (+ 9 (random 4))))
         (newline)
         (loop (1+ i)))
      'done)))

Vectors and Structures

vector 是使用整數索引的資料,可儲存不同資料型別的資料。跟 list 比較,vector資料更緊密且存取時間很短。但是 vector 是透過 side effect 來處理資料,會造成一些問題。

scheme 的 structures 跟 C 語言類似,但更容易使用,因為 scheme 為 structure 提供了讀取及寫入的函數(使用了 Lisp/Scheme 的 macro)。

vector

#( ) 表示,例如 #(1 2 3),作為 literals 時,必須要 quoted

ex:

'#(1 2 3) 整數向量

'#(a 0 #\a) symbol, 整數, char 的向量

R5RS規格中的向量函數

  • (vector? obj)

    如果obj是一個向量則返回#t。

  • (make-vector k) (make-vector k fill)

    返回有 k 個元素的向量。如果指定了第二個參數(fill),那麼所有的元素都會被初始化為fill。

  • (vector obj …)

    返回由參數列表構成的向量。

  • (vector-length vector)

    返回向量 vector 的長度。

  • (vector-ref vector k)

    返回向量 vector 的索引為 k 的元素。(向量的索引從0開始。)

  • (vector-set! vector k obj)

    將向量 vector 的索引為 k 的元素修改為 obj。

  • (vector->list vector)

    將 vector 轉換為 list。

  • (list->vector list)

    將 list 轉換為向量。

  • (vector-fill! vector fill)

    將向量 vector 的所有元素設定為 fill。

ex: 向量加法

(define (vector-add v1 v2)
  (let ((lenv1 (vector-length v1))
          (lenv2 (vector-length v2)))
    (if (= lenv1 lenv2)
          (let ((v (make-vector lenv1)))
            (let loop ((i 0))
              (if (= i lenv1)
                    v
                    (begin
                      (vector-set! v i (+ (vector-ref v1 i) (vector-ref v2 i)))
                      (loop (+ 1 i))))))
        (error "different dimensions."))))

(vector-add #(1 2 3) #(1 2 3))
;Value 2: #(2 4 6)

ex: 向量內積

(define (inner-product vec1 vec2)
  (let ((len1 (vector-length vec1))
          (len2 (vector-length vec2)))
    (if (= len1 len2)
        (let loop ((i 0) (pro 0))
          (if (= i len1)
              pro
              (loop (+ 1 i)
                  (+ pro (* (vector-ref vec1 i) (vector-ref vec2 i))))))
        (error "different dimensions."))))


(inner-product #(1 2 3) #(1 2 3))
;Value: 14

structure

R5RS 沒有定義 structure,但在 scheme 有實作類似於 Common Lisp 的 structure。

structure 本質上就是向量。每一個 slot 都透過 macro 來命名。

scheme 透過 define-structure 定義 structure,例如 定義書籍

(define-structure book title authors publisher year isbn)

(define bazaar 
  (make-book 
   "The Cathedral and the Bazaar"
   "Eric S. Raymond"
   "O'Reilly"
   1999
   0596001088))

但這樣定義,並沒有明確的屬性定義,改用 keyword-constructor 解決這個問題,其中參數 copier可用於為 structure 建立一個拷貝(copier)函數

(define-structure (book keyword-constructor copier) 
  title authors publisher year isbn)

(define bazaar 
  (make-book 
   'title "The Cathedral and the Bazaar"
   'authors "Eric S. Raymond"
   'publisher "O'Reilly"
   'year 1999    
   'isbn 0596001088))

支援 structure 的函數

  • [the name of structure]?的函數用於檢查某對象是否為特定structure。例如,可使用函數book?來檢查bazaar是否為book結構的一個實例。

    (book? bazaar)
    ;Value: #t
  • copy-[structure name] 函數用於拷貝結構。例如將 bazaar 複製到 cathedral

    (define cathedral (copy-book bazaar))
  • [structure name]-[attribute name] 函數用於讀取structure 某屬性的值。例如,讀取bazaartitle屬性。

    (book-title bazaar)
    ;Value 3: "The Cathedral and the Bazaar"
  • set-[結構體名稱]-[屬性名稱]!用於將某屬性設定為特定值

    (set-book-year! bazaar 2001)
    ;Unspecified return value
    
    (book-year bazaar)
    ;Value: 2001

Sample: Mastermind

一個猜對手密碼的遊戲。密碼是由0到9中四個不同的數組成的四位數。對手要通過使用bullscows的數量告知猜謎者猜測的準確程度。

  1. bull的數量(Nbull)是指值和位置都正確的數字的數量。
  2. cow的數量(Ncow)是指值正確但位置錯誤的數字的數量。

例如,密碼是5601,猜測是1685,那麼bullcow和數分別是1和2。

程式和用戶相互猜測對方的密碼。嘗試次數少的為勝利者。如果用戶和電腦在相同的嘗試次數中破解了密碼就是平局。

表示數字的方法:

產生長度為 10 的向量,索引值 k 表示 k 在密碼中的位置,四個位置為 1, 2, 3, 4,如果該數字沒乙出現,就是 0

5601  ->  #(2 1 0 0 0 4 3 0 0 0)   ; 數字0,1,5,和6分別出現在第2,第1,第4和第3位
1685  ->  #(0 4 0 0 0 1 3 0 2 0)

這樣的表示方式,可以快速地比較兩個數字,如果兩個向量,在相同索引位置的值都是正數,如果該值相等,就記為 bull,如果值不相等,就計為 cow。

以 5601 與 1685 為例,索引位置 6 的值都是 3,索引位置 1, 5 的值都是正數,bull, cow 的值是 1 與 2。

程式:
  1. 產生成一個 list,該表包含了所有不同四位數的向量表示。
  2. 從 list 中隨機選取一個數字。
  3. 重洗步驟(1)產生的表。
  4. 程式首次猜用戶的密碼,用戶給出bull和cow的數量。然後用戶猜程序的密碼,程序給出Nnull和Ncow。
  5. 重複步驟(3)直到程式的bull數量變為4為止。如果在同一次雙方的數量都變為4,就是平局。
測試:

先編譯程式再執行

(compile-file "mastermind.scm")
(load "mastermind")
(mastermind)

References

mit-scheme user doc

Yet Another Scheme Tutorial 中文版

Yet Another Scheme Tutorial

2019/11/25

Scheme Tutorial 2

local variables

用 let 定義 local variable,body由任意多個S-表達式構成,變數的Scopebody,只在body 中有效。

(let binds body)

;binds的格式
[binds] → ((p1 v1) (p2 v2) ...)

ex:

(let ((i 1) (j 2))
  (+ i j))
;Value: 3

let 可以嵌套使用

(let ((i 1))
  (let ((j (+ i 2)))
    (* i j)))
;Value: 3

因變數的作用域僅在body中,下列代碼會產生錯誤,因為在變量j的作用域中沒有變數i的定義。

(let ((i 1) (j (+ i 2)))
  (* i j))
;Error

let*表達式可以用於引用定義在同一個綁定中的變量。實際上,let*只是嵌套的let表達式的 syntax sugar 而已。

(let* ((i 1) (j (+ i 2)))
  (* i j))
;Value: 3

ex: 計算一元二次方程式的解。它需要三個參數代表係數:abcax^2 + bx + c = 0),計算結果傳回一個存放答案的實數表。

(define (quadric-equation a b c)
  (if (zero? a)
      'error                                      ; 1 如果二次項係數 a為0,函數返回'error
      (let ((d (- (* b b) (* 4 a c))))            ; 2 如果a ≠ 0,則將變數d與判別式(b^2 - 4ac)的值綁定
        (if (negative? d)
            '()                                      ; 3 如果d為負數,則返回'()
            (let ((e (/ b a -2)))                    ; 4 如果d不為負數,則將變數 e 與-b/2a 綁定
                (if (zero? d)
                    (list e)                            ; 5 如果 d為0,則返回一個包含e的表
                    (let ((f (/ (sqrt d) a 2)))         ; 6 如果 d是正數,則將變數 f 與√(d/2a)綁定,並返回由(+ e f)和(- e f)> 構成的表
                    (list (+ e f) (- e f)))))))))

(quadric-equation 3 5 2)  ; solution of 3x^2+5x+2=0
;Value 12: (-2/3 -1)

let expression 實際上只是 lambda expression 的 syntax sugar

(let ((p1 v1) (p2 v2) ...) exp1 exp2 ...)
;⇒
((lambda (p1 p2 ...)
    exp1 exp2 ...) v1 v2)

因為 lambda 用來定義函數,同時定義了該變數的作用範圍

ex: 用一個初始速度v和與水平面所成夾角a來計算飛行距離

(define (throw v a)
  (let ((r (/ (* 4 a (atan 1.0)) 180)))  ; (define pi (* 4 (atan 1.0)))  r 可將 degree 轉換為 radian
    (/ (* 2 v v (cos r) (sin r)) 9.8)))  ; 初始水平、竪直分速度分別表示為:v*cos(theta1)和v*sin(theta1)  落地時瞬時竪直分速度為-Vy  自由落體時間 2Vy = g*t


(throw 40 30)
;Value: 141.39190265868385

在 scheme 中,變數的作用範圍由 source code 決定,這稱為 lexical closure

Looping 迴圈

在 scheme 通常用遞迴來處理 looping

Recursion 遞迴

在函數定義中呼叫函數本身,就稱為遞迴函數。

ex: 計算階乘

(define (fact n)
  (if (= n 1)
      1
      (* n (fact (- n 1)))))

過程如下

(fact 5)
⇒ 5 * (fact 4)
⇒ 5 * 4 * (fact 3)
⇒ 5 * 4 * 3 * (fact 2)
⇒ 5 * 4 * 3 * 2 * (fact 1)
⇒ 5 * 4 * 3 * 2 * 1
⇒ 5 * 4 * 3 * 2
⇒ 5 * 4 * 6
⇒ 5 * 24
⇒ 120

list 可以用遞迴的方式定義,例如讓 list 裡面所有元素都乘以2 可這樣寫

(define (list*2 ls)
  (if (null? ls)
      '()
      (cons (* 2 (car ls))
           (list*2 (cdr ls)))))

(list*2 (list 1 2 3 4 5))
;Value 8: (2 4 6 8 10)

ex:

; 1 計算 list 內元素的個數
(define (my-length ls)
  (if (null? ls)
      0
      (+ 1 (my-length (cdr ls)))))

; 2 加總 list 內所有元素
(define (my-sum ls)
  (if (null? ls)
      0
      (+ (car ls) (my-sum (cdr ls)))))

; 3 從 ls 中刪除 x 後得到的表
(define (remove x ls)
  (if (null? ls)
      '()
      (let ((h (car ls)))
        ((if (eqv? x h)
            (lambda (y) y)
            (lambda (y) (cons h y)))
         (remove x (cdr ls))))))

; 4 傳回 x 在 ls 中首次出現的位置。索引從0開始。如果 x 不在ls中,函數傳回 #f
(define (position x ls)
  (position-aux x ls 0))

(define (position-aux x ls i)
  (cond
   ((null? ls) #f)
   ((eqv? x (car ls)) i)
   (else (position-aux x (cdr ls) (1+ i)))))

尾遞迴

普通的遞迴並不高效因為它既浪費儲存空間又具有呼叫函數的開銷。尾遞迴函數包含了計算結果,當計算結束時直接將其回傳。另外由於Scheme規範中要求尾遞迴呼叫轉化為循環,因此尾遞迴呼叫就不存在呼叫函數的開銷。

ex: 階乘的尾遞迴版本

(define (fact-tail n)
  (fact-rec n n))

(define (fact-rec n p)
  (if (= n 1)
      p
      (let ((m (- n 1)))
  (fact-rec m (* p m)))))

計算過程如下

(fact-tail 5)
⇒ (fact-rec 5 5)
⇒ (fact-rec 4 20)
⇒ (fact-rec 3 60)
⇒ (fact-rec 2 120)
⇒ (fact-rec 1 120)
⇒ 120

Scheme將尾遞迴轉化為循環,Scheme就無需提供循環的語法來實現 looping。

ex:

; 1 翻轉 list 元素的順序
(define (my-reverse ls)
  (my-reverse-rec ls ()))

(define (my-reverse-rec ls0 ls1)
  (if (null? ls0)
      ls1
      (my-reverse-rec (cdr ls0) (cons (car ls0) ls1))))

;-------------------
; 2 加總 list
(define (my-sum-tail ls)
  (my-sum-rec ls 0))

(define (my-sum-rec ls n)
  (if (null? ls)
      n
      (my-sum-rec (cdr ls) (+ n (car ls)))))

;--------------------
; 3 將一個代表正整數的字串轉化為對應整數。 例如 "1232" 轉換為 1232,不檢查非法的字元
; 字元到整數的轉化是通過將字元 #\0 …… #\9 的ASCII減去48,可以使用函數char->integer來獲得字符的ASCII碼。
; 函數 string->list 可以將字串轉化為由字元構成的 list。
(define (my-string->integer str)
  (char2int (string->list str) 0))

(define (char2int ls n)
  (if (null? ls)
      n
      (char2int (cdr ls)
    (+ (- (char->integer (car ls)) 48)
       (* n 10)))))

named let 有命名的 let

named let 可用來處理 looping

ex: 用 named let 實作階乘

(define (fact-let n)
  (let loop((n1 n) (p n))     ; 1  將參數 n1 與 p 都初始化為 n
    (if (= n1 1)
      p
      (let ((m (- n1 1)))
      (loop m (* p m))))))    ; 2  每一次循環時,n1 會減 1, p 會乘以 (n1-1)

ex:

; 1  從 ls 中刪除 x 後得到的表
(define (remove x ls)
  (let loop( (ls0 ls) (ls1 ()) )
    (if (null? ls0)
      (reverse ls1)
      (loop
        (cdr ls0)
        (if (eqv? x (car ls0))
            ls1
            (cons (car ls0) ls1) )))))

; 2  傳回 x 在 ls 中首次出現的位置。索引從0開始。如果 x 不在ls中,函數傳回 #f
(define (position x ls)
  (let loop((ls0 ls) (i 0))
    (cond
     ((null? ls0) #f)
     ((eqv? x (car ls0)) i)
     (else (loop (cdr ls0) (1+ i))))))

; 3  翻轉 list 元素的順序
(define (my-reverse-let ls)
  (let loop( (ls0 ls) (ls1 ()) )
    (if (null? ls0)
      ls1
      (loop (cdr ls0) (cons (car ls0) ls1)))))

; 4  加總 list
(define (my-sum-let ls)
  (let loop((ls0 ls) (n 0))
    (if (null? ls0)
  n
  (loop (cdr ls0) (+ (car ls0) n)))))

; 5  將一個代表正整數的字串轉化為對應整數
(define (my-string->integer-let str)
  (let loop((ls0 (string->list str)) (n 0))
    (if (null? ls0)
  n
  (loop (cdr ls0)
        (+ (- (char->integer (car ls0)) 48)
     (* n 10))))))

; 6  range函數:傳回一個從0到n的表(但不包含n)
(define (range n)
  (let loop((i 0) (ls1 ()))
    (if (= i n)
      (reverse ls1)
      (loop (1+ i) (cons i ls1)))))

letrec

letrec 類似let,但允許一個名字遞迴呼叫自己。通常用來定義複雜的遞迴函數 recursive local functions。

; 階乘的 letrec 版本
(define (fact-letrec n)
  (letrec ((iter (lambda (n1 p)
       (if (= n1 1)
           p
           (let ((m (- n1 1)))  (iter m (* p m))) ))))     ; iter 可在定義中引用自己
       (iter n n) ))

letrec 的語法,前面是變數定義區塊,<body> 是執行區塊

(letrec ((<variable> <init>) ...) <body>) 

letrec最常見的用法就是用於綁定函數對象,讓變數定義區塊V裡面定義的所有變量可以在執行時相互引用,不受位置前後的限制

(letrec ((x (lambda () (+ y y)))
         (y 100))
    (+ (x) y))

; 執行(+ (x) y)時,雖然 y在x之後才綁定的,函數對象x可以讀取y對象的值

(define x (lambda () (+ y y)))

(define y 100)

(+ (x) y)

ex:

; 1  翻轉 list 元素的順序
(define (my-reverse-letrec ls)
  (letrec ((iter (lambda (ls0 ls1)
       (if (null? ls0)
           ls1
           (iter (cdr ls0) (cons (car ls0) ls1))))))
    (iter ls ())))

; 2  加總 list
(define (my-sum-letrec ls)
  (letrec ((iter (lambda (ls0 n)
       (if (null? ls0)
           n
           (iter (cdr ls0) (+ (car ls0) n))))))
    (iter ls 0)))

; 3  將一個代表正整數的字串轉化為對應整數。
(define (my-string->integer-letrec str)
  (letrec ((iter (lambda (ls0 n)
       (if (null? ls0)
           n
           (iter (cdr ls0)
           (+ (- (char->integer (car ls0)) 48)
        (* n 10)))))))
    (iter (string->list str) 0)))

do

不常用,但 do 也可以處理 looping,語法如下:

(do binds (predicate value)
    body)

變數在 binds 部份被綁定,如果 predicate 為 #t,則函數由循環中 escape,並回傳 value,否則繼續 looping

binds 的格式如下,變量p1p2,…被分別初始化為i1i2,…並在循環後分別被更新為u1u2,…。

[binds] → ((p1 i1 u1) (p2 i2 u2) ... )

ex:

; 變數n1和p分別被初始化為n和n,在每次循環後,分別被 減去1 和 乘以(n1 - 1)。當n1變為1時,函數返回p。
(define (fact-do n)
  (do ((n1 n (- n1 1)) (p n (* p (- n1 1)))) ((= n1 1) p)))
; 1  翻轉 list 元素的順序
(define (my-reverse-do ls)
  (do ((ls0 ls (cdr ls0))  (ls1 () (cons (car ls0) ls1)))
      ((null? ls0) ls1)))

; 2  加總 list
(define (my-sum-do ls)
  (do ((ls0 ls (cdr ls0))  (n 0 (+ n (car ls0))))
      ((null? ls0) n)))

; 3  將一個代表正整數的字串轉化為對應整數。
(define (my-string->integer-do str)
  (do ((ls0 (string->list str) (cdr ls0))
       (n 0 (+ (- (char->integer (car ls0)) 48)
         (* n 10))))
      ((null? ls0) n)))

通常來說,named let 用於簡單的循環,而letrec則是用來寫複雜的局部遞歸函數。

高階函數 higher order function

高階函數 higher order function 是一種以函數為參數的函數,用於 mapping, filtering, folding, sorting list。高階函數增加了程式的模組特性。例如使用高階函數實作 sorting,可將排序條件與過程分離。

例如 sort 有兩個參數:一個是待排序的 list,一個是 Ordering function

(sort '(7883 9099 6729 2828 7754 4179 5340 2644 2958 2239) <)
;Value 12: (2239 2644 2828 2958 4179 5340 6729 7754 7883 9099)

; 改以數字末兩位排序
(sort '(7883 9099 6729 2828 7754 4179 5340 2644 2958 2239)
      (lambda (x y) (< (modulo x 100) (modulo y 100))))
;Value 13: (2828 6729 2239 5340 2644 7754 2958 4179 7883 9099)

映射 Mapping

map

procedure是個與某個過程或lambda表達式相綁定的符號。作為參數的表的個數,視procedure需要的參數而定。

(map procedure list1 list2 ...)

ex:

; Adding each item of '(1 2 3) and '(4 5 6).
(map + '(1 2 3) '(4 5 6))
;Value 14: (5 7 9)

; Squaring each item of '(1 2 3)
(map (lambda (x) (* x x)) '(1 2 3))
;Value 15: (1 4 9)
for-each

for-each的格式與map一致。但for-each並不返回一個具體的值,只是用於副作用。

ex:

(define sum 0)

(for-each (lambda (x) (set! sum (+ sum x))) '(1 2 3 4))

sum
;Value: 10

ex: 將 list 裡所有元素 *2

(define (double list)
    (map (lambda (x) (* x 2)) list) )

(double '(1 2 3))
;Value 16: (2 4 6)

(double (list 1 2 3))
;Value 17: (2 4 6)

ex: 將兩個表中對應位置元素相減的函數

(define (minus list1 list2)
    (map - list1 list2) )

(minus '(1 2 3) '(4 5 6))
;Value 18: (-3 -3 -3)

filtering

R5RS 沒有定義 filtering 函數,但 scheme 提供了 keep-matching-items 與 delete-matching-item

(keep-matching-items '(1 2 -3 -4 5) positive?)
;Value 19: (1 2 5)

ex:

; 過濾出偶數
(keep-matching-items '(1 2 -3 -4 5) (lambda (x) (= (modulo x 2) 0)))
;Value 20: (2 -4)

; 濾出 不滿足10 ≤ x ≤ 100 的數
(keep-matching-items '(1 10 20 50 100 150) (lambda (x) (not (<= 10 x 100))))
;Value 23: (1 150)

Folding

R5RS 沒有定義 folding 函數,但 scheme 提供了 reduce

(reduce + 0 '(1 2 3 4))                 ;⇒  10
(reduce + 0 '(1 2))                     ;⇒  3
(reduce + 0 '(1))                       ;⇒  1
(reduce + 0 '())                        ;⇒  0
(reduce + 0 '(foo))                     ;⇒  foo
(reduce list '() '(1 2 3 4))            ;⇒  (4 (3 (2 1)))

ex: 撰寫將表中所有元素平方的函數,然後求取它們的和,最後求和的平方根

(define (fun list)
    (sqrt (reduce + 0 (map (lambda (x) (* x x)) list))))

(fun '(3 4))
;Value: 5

Sorting

R5RS中沒有定義排序函數,但 scheme 提供了 sort (merge-sort 實作) 與 quick-sort

(sort '(3 5 1 4 -1) <)
;Value 26: (-1 1 3 4 5)

ex:

; 以sin(x)的大小升序排序
(define (sort-sin ls)
  (sort ls (lambda (x y) (< (sin x) (sin y)))))

; 以list長度降序排序
(define (sort-length ls)
  (sort ls (lambda (x y) (> (length x) (length y)))))

apply

將一個過程應用於一個表(將表展開,作為過程的參數),函數可有多個參數,但首參數和末參數分別應該是一個過程和一個表

(apply max '(1 3 2))      ;⇒   3
(apply + 1 2 '(3 4 5))    ;⇒  15
(apply - 100 '(5 12 17))  ;⇒  66

ex: 撰寫將表中所有元素平方的函數,然後求取它們的和,最後求和的平方根

(define (sqrt-sum-sq-a ls)
  (sqrt (apply + (map (lambda (x) (* x x)) ls))))

編寫高階函數

member-if, member

member-if, member

member-if函數使用一個謂詞和一個表作為參數,返回一個子表,該子表的car部分即是原列表中首個滿足該謂詞的元素。

(define (member-if proc ls)
  (cond
   ((null? ls) #f)
   ((proc (car ls)) ls)
   (else (member-if proc (cdr ls)))))

(member-if positive? '(0 -1 -2 3 5 -7))
;⇒  (3 5 -7)

member函數檢查特定元素是否在表中,使用三個參數,其一為用於比較的函數,其二為特定項,其三為待查找表。

(define (member proc obj ls)
  (cond
   ((null? ls) #f)
   ((proc obj (car ls)) ls)
   (else (member proc obj (cdr ls)))))

(member string=? "hello" '("hi" "guys" "bye" "hello" "see you"))
;⇒  ("hello" "see you")

References

mit-scheme user doc

Yet Another Scheme Tutorial 中文版

Yet Another Scheme Tutorial