arc (adaptive range coder) は適応型レンジコーダでファイルを圧縮するライブラリです。レンジコーダの本体はライブラリ rangecoder に定義されています。記号の出現確率を求めるため、ライブラリ bitree を使っています。詳しい説明は以下の拙作のページをお読みください。
アーカイブファイル minlib.tar.gz をインストールする、または プログラムリスト にある以下の 10 つのファイルを、~/common-lisp/ 以下の適当なサブディレクトリ (たとえば rangecoder など) に配置してください。
* (asdf:test-system :arc) ; compiling file ... 略 ... ----- test start ----- (ARC-ENCODE RC BT 0) => NIL OK (ARC-ENCODE RC BT 1) => NIL OK (ARC-ENCODE RC BT 2) => NIL OK (ARC-ENCODE RC BT 3) => NIL OK (ARC-ENCODE RC BT 4) => NIL OK (ARC-ENCODE RC BT 5) => NIL OK (ARC-ENCODE RC BT 6) => NIL OK (ARC-ENCODE RC BT 7) => NIL OK (ARC-DECODE RC BT) => 0 OK (ARC-DECODE RC BT) => 1 OK (ARC-DECODE RC BT) => 2 OK (ARC-DECODE RC BT) => 3 OK (ARC-DECODE RC BT) => 4 OK (ARC-DECODE RC BT) => 5 OK (ARC-DECODE RC BT) => 6 OK (ARC-DECODE RC BT) => 7 OK ----- test end ----- TEST: 16 OK: 16 NG: 0 ERR: 0 T
* (asdf:test-system :brc) ; compiling file ... 略 ... ----- test start ----- (BIT-CONTEXT-P (SETQ BC (MAKE-BIT-CONTEXT))) => T OK ; bit-context のテストは省略 (BINARY-MODEL-P (SETQ BM (INITIALIZE-BINARY-MODEL 8))) => T OK (BM-ENCODE RC BM 0) => NIL OK (BM-ENCODE RC BM 1) => NIL OK (BM-ENCODE RC BM 2) => NIL OK (BM-ENCODE RC BM 3) => NIL OK (BM-ENCODE RC BM 4) => NIL OK (BM-ENCODE RC BM 5) => NIL OK (BM-ENCODE RC BM 6) => NIL OK (BM-ENCODE RC BM 7) => NIL OK (BM-DECODE RC BM) => 0 OK (BM-DECODE RC BM) => 1 OK (BM-DECODE RC BM) => 2 OK (BM-DECODE RC BM) => 3 OK (BM-DECODE RC BM) => 4 OK (BM-DECODE RC BM) => 5 OK (BM-DECODE RC BM) => 6 OK (BM-DECODE RC BM) => 7 OK (ALPHA-MODEL-P (SETQ AM (INITIALIZE-ALPHA-MODEL 8))) => T OK (ALPHA-ENCODE RC AM 0) => NIL OK (ALPHA-ENCODE RC AM 1) => NIL OK (ALPHA-ENCODE RC AM 2) => NIL OK (ALPHA-ENCODE RC AM 3) => NIL OK (ALPHA-ENCODE RC AM 4) => NIL OK (ALPHA-ENCODE RC AM 5) => NIL OK (ALPHA-ENCODE RC AM 6) => NIL OK (ALPHA-ENCODE RC AM 7) => NIL OK (ALPHA-DECODE RC AM) => 0 OK (ALPHA-DECODE RC AM) => 1 OK (ALPHA-DECODE RC AM) => 2 OK (ALPHA-DECODE RC AM) => 3 OK (ALPHA-DECODE RC AM) => 4 OK (ALPHA-DECODE RC AM) => 5 OK (ALPHA-DECODE RC AM) => 6 OK (ALPHA-DECODE RC AM) => 7 OK (BITS-MODEL-P (SETQ BS (INITIALIZE-BITS-MODEL 3))) => T OK ; bits-model のテストは省略 (GAMMA-MODEL-P (SETQ GM (INITIALIZE-GAMMA-MODEL 256))) => T OK (GAMMA-ENCODE RC GM 0) => NIL OK (GAMMA-ENCODE RC GM 15) => NIL OK (GAMMA-ENCODE RC GM 16) => NIL OK (GAMMA-ENCODE RC GM 31) => NIL OK (GAMMA-ENCODE RC GM 32) => NIL OK (GAMMA-ENCODE RC GM 63) => NIL OK (GAMMA-ENCODE RC GM 64) => NIL OK (GAMMA-ENCODE RC GM 255) => NIL OK (GAMMA-DECODE RC GM) => 0 OK (GAMMA-DECODE RC GM) => 15 OK (GAMMA-DECODE RC GM) => 16 OK (GAMMA-DECODE RC GM) => 31 OK (GAMMA-DECODE RC GM) => 32 OK (GAMMA-DECODE RC GM) => 63 OK (GAMMA-DECODE RC GM) => 64 OK (GAMMA-DECODE RC GM) => 255 OK ----- test end ----- TEST: 85 OK: 85 NG: 0 ERR: 0 T
;;;
;;; rca.lisp : 適応型レンジコーダ
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :arc)
(use-package '(:arc :bitree :rangecoder))
;;; ファイルサイズの書き込み
(defun write-file-size (out size)
(write-byte (logand (ash size -24) #xff) out)
(write-byte (logand (ash size -16) #xff) out)
(write-byte (logand (ash size -8) #xff) out)
(write-byte (logand size #xff) out))
;;; ファイルサイズの読み込み
(defun read-file-size (in)
(+ (ash (read-byte in) 24)
(ash (read-byte in) 16)
(ash (read-byte in) 8)
(read-byte in)))
;;; ファイルの符号化
(defun encode-file (in-file out-file)
(call-with-byte-output-file
out-file
(lambda (out)
(call-with-byte-input-file
in-file
(lambda (in)
(let ((size (file-length in))
(bt (bitree-initialize 256)))
(write-file-size out size)
(when (plusp size)
(call-with-range-encoder
out
(lambda (rc)
(dotimes (x size)
(arc-encode rc bt (read-byte in))))))))))))
;;; ファイルの復号
(defun decode-file (in-file out-file)
(call-with-byte-input-file
in-file
(lambda (in)
(let ((size (read-file-size in))
(bt (bitree-initialize 256)))
(call-with-byte-output-file
out-file
(lambda (out)
(when (plusp size)
(call-with-range-decoder
in
(lambda (rc)
(dotimes (x size)
(write-byte (arc-decode rc bt) out)))))))))))
;;; 簡単なテスト
(defun test ()
(let ((files '("alice29.txt" "asyoulik.txt" "cp.html" "fields.c" "grammar.lsp"
"kennedy.xls" "lcet10.txt" "plrabn12.txt" "ptt5" "sum" "xargs.1")))
(format t "----- encode -----~%")
(time
(dolist (file files)
(encode-file (format nil "./canterbury/~a" file)
(format nil "~a.en" file))))
;;
(format t "----- decode -----~%")
(time
(dolist (file files)
(decode-file (format nil "~a.en" file)
(format nil "~a.de" file))))))
* (load "rca.lisp") T * (test) ----- encode ----- Evaluation took: 0.730 seconds of real time 0.587270 seconds of total run time (0.579684 user, 0.007586 system) 80.41% CPU 1,763,817,100 processor cycles 63,296 bytes consed ----- decode ----- Evaluation took: 1.039 seconds of real time 1.030974 seconds of total run time (1.030974 user, 0.000000 system) 99.23% CPU 2,485,250,688 processor cycles 64,608 bytes consed NIL
表 : 適応型レンジコーダの結果
ファイル名 サイズ ARC
----------------------------------
alice29.txt 152,089 87,147
asyoulik.txt 125,179 75,533
cp.html 24,603 16,299
fields.c 11,150 7,164
grammar.lsp 3,721 2,305
kennedy.xls 1,029,744 460,734
lcet10.txt 426,754 249,491
plrabn12.txt 481,861 273,392
ptt5 513,216 78,090
sum 38,240 25,638
xargs.1 4,227 2,743
----------------------------------
合計 2,810,784 1,278,536
実行環境 : SBCL 2.1.11, Ubunts 22.04 (WSL2), Intel Core i5-6200U 2.30GHz
;;;
;;; rcb.lisp : バイナリレンジコーダ
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :brc)
(use-package '(:brc :rangecoder))
;;; ファイルサイズの書き込み
(defun write-file-size (out size)
(write-byte (logand (ash size -24) #xff) out)
(write-byte (logand (ash size -16) #xff) out)
(write-byte (logand (ash size -8) #xff) out)
(write-byte (logand size #xff) out))
;;; ファイルサイズの読み込み
(defun read-file-size (in)
(+ (ash (read-byte in) 24)
(ash (read-byte in) 16)
(ash (read-byte in) 8)
(read-byte in)))
;;; ファイルの符号化
(defun encode-file (in-file out-file)
(call-with-byte-output-file
out-file
(lambda (out)
(call-with-byte-input-file
in-file
(lambda (in)
(let ((size (file-length in))
(bm (initialize-binary-model 256)))
(write-file-size out size)
(when (plusp size)
(call-with-range-encoder
out
(lambda (rc)
(dotimes (x size)
(bm-encode rc bm (read-byte in))))))))))))
;;; ファイルの復号
(defun decode-file (in-file out-file)
(call-with-byte-input-file
in-file
(lambda (in)
(let ((size (read-file-size in))
(bm (initialize-binary-model 256)))
(call-with-byte-output-file
out-file
(lambda (out)
(when (plusp size)
(call-with-range-decoder
in
(lambda (rc)
(dotimes (x size)
(write-byte (bm-decode rc bm) out)))))))))))
;;; 簡単なテスト
(defun test ()
(let ((files '("alice29.txt" "asyoulik.txt" "cp.html" "fields.c" "grammar.lsp"
"kennedy.xls" "lcet10.txt" "plrabn12.txt" "ptt5" "sum" "xargs.1")))
(format t "----- encode -----~%")
(time
(dolist (file files)
(encode-file (format nil "./canterbury/~a" file)
(format nil "~a.en" file))))
;;
(format t "----- decode -----~%")
(time
(dolist (file files)
(decode-file (format nil "~a.en" file)
(format nil "~a.de" file))))))
* (load "rcb.lisp") T * (test) ----- encode ----- Evaluation took: 1.970 seconds of real time 1.974671 seconds of total run time (1.944401 user, 0.030270 system) 100.25% CPU 4,739,324,880 processor cycles 162,816 bytes consed ----- decode ----- Evaluation took: 2.180 seconds of real time 2.182218 seconds of total run time (2.172204 user, 0.010014 system) 100.09% CPU 5,237,354,085 processor cycles 143,968 bytes consed NIL
表 : バイナリレンジコーダの結果
ARC : 適応型レンジコーダ (多値)
Binary : バイナリレンジコーダ (Binary-Model)
ファイル名 サイズ ARC Binary
--------------------------------------------
alice29.txt 152,089 87,147 86,921
asyoulik.txt 125,179 75,533 75,320
cp.html 24,603 16,299 16,152
fields.c 11,150 7,164 7,043
grammar.lsp 3,721 2,305 2,206
kennedy.xls 1,029,744 460,734 460,167
lcet10.txt 426,754 249,491 249,157
plrabn12.txt 481,861 273,392 273,046
ptt5 513,216 78,090 77,762
sum 38,240 25,638 25,599
xargs.1 4,227 2,743 2,642
--------------------------------------------
合計 2,810,784 1,278,536 1,276,015
;;;
;;; rangecoder.lisp : rangecoder のコアな処理
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :rangecoder)
(defpackage :rangecoder (:use :cl))
(in-package :rangecoder)
(export '(range-coder
range-coder-p
range-coder-low
range-coder-range
min-range
call-with-byte-input-file
call-with-byte-output-file
call-with-range-encoder
call-with-range-decoder
encode-normalize
decode-normalize))
;;; バイト入力用ファイルオープン
(defun call-with-byte-input-file (filename proc)
(with-open-file (in filename
:direction :input
:element-type 'unsigned-byte)
(funcall proc in)))
;;; バイト出力用ファイルオープン
(defun call-with-byte-output-file (filename proc)
(with-open-file (out filename
:direction :output
:if-exists :rename-and-delete
:element-type 'unsigned-byte)
(funcall proc out)))
;;; 定数
(defconstant max-range #x100000000)
(defconstant min-range #x1000000)
(defconstant mask #xffffffff)
(defconstant ff-check #xff000000)
;;; 構造体の定義
(defstruct range-coder
direction file range low buff cnt)
;;; buff と記号 c を n 個書き出す
(defun flush-buff (rc c n)
(write-byte (range-coder-buff rc) (range-coder-file rc))
(dotimes (x n)
(write-byte c (range-coder-file rc))))
;;; 終了処理
(defun finish (rc out)
(if (< (range-coder-low rc) max-range)
(flush-buff rc #xff (range-coder-cnt rc))
;; 桁上がり
(progn
(incf (range-coder-buff rc))
(flush-buff rc 0 (range-coder-cnt rc))))
;;
(write-byte (logand (ash (range-coder-low rc) -24) #xff) out)
(write-byte (logand (ash (range-coder-low rc) -16) #xff) out)
(write-byte (logand (ash (range-coder-low rc) -8) #xff) out)
(write-byte (logand (range-coder-low rc) #xff) out))
;;; 符号化用レンジコーダ
(defun call-with-range-encoder (out proc)
(let ((rc (make-range-coder :direction :encode
:file out
:range max-range
:low 0
:buff 0
:cnt 0)))
(funcall proc rc)
;; 終了処理
(finish rc out)))
;;; 復号用レンジコーダ
(defun call-with-range-decoder (in proc)
(let ((rc (make-range-coder :direction :decode
:file in
:range max-range
:buff 0
:cnt 0)))
;; buff の初期値 (0) を読み捨てる
(read-byte in)
;; 4 byte read
(setf (range-coder-low rc)
(+ (ash (read-byte in) 24)
(ash (read-byte in) 16)
(ash (read-byte in) 8)
(read-byte in)))
;;
(funcall proc rc)))
;;; 符号化の正規化
(defun encode-normalize (rc)
(when (>= (range-coder-low rc) max-range)
;; 桁上がり
(incf (range-coder-buff rc))
(setf (range-coder-low rc)
(logand (range-coder-low rc) mask))
(when (plusp (range-coder-cnt rc))
(flush-buff rc 0 (1- (range-coder-cnt rc)))
(setf (range-coder-buff rc) 0
(range-coder-cnt rc) 0)))
(do ()
((>= (range-coder-range rc) min-range))
(cond ((< (range-coder-low rc) ff-check)
(flush-buff rc #xff (range-coder-cnt rc))
(setf (range-coder-buff rc)
(logand (ash (range-coder-low rc) -24) #xff)
(range-coder-cnt rc)
0))
(t (incf (range-coder-cnt rc))))
(setf (range-coder-low rc)
(logand (ash (range-coder-low rc) 8) mask)
(range-coder-range rc)
(ash (range-coder-range rc) 8))))
;;; 復号の正規化
(defun decode-normalize (rc)
(do ()
((>= (range-coder-range rc) min-range))
(setf (range-coder-range rc)
(ash (range-coder-range rc) 8)
(range-coder-low rc)
(logand (+ (ash (range-coder-low rc) 8)
(read-byte (range-coder-file rc)))
mask))))
リスト : rangeocder.asd (defsystem :rangecoder :description "range coder のコアな処理" :version "0.1.0" :author "Makoto Hiroi" :license "MIT" :depends-on () :components ((:file "rangecoder")))
;;;
;;; arc.lisp : 適応型 rangecoder
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :arc)
(defpackage :arc (:use :cl :bitree :rangecoder))
(in-package :arc)
(export '(arc-encode
arc-decode))
;;; 更新
(defun arc-update (bt c limit inc)
(bitree-add bt c inc)
(when (<= limit (bitree-total bt))
(bitree-half bt)))
;;; 適応型レンジコーダの符号化
(defun arc-encode (rc bt c &key (limit min-range) (inc 1))
(let ((temp (floor (range-coder-range rc)
(bitree-total bt))))
(incf (range-coder-low rc)
(* (bitree-sum bt c) temp))
(setf (range-coder-range rc)
(* (bitree-get bt c) temp))
(encode-normalize rc)
(arc-update bt c limit inc)))
;;; 適応型レンジコーダの符号化
(defun arc-decode (rc bt &key (limit min-range) (inc 1))
(let ((temp (floor (range-coder-range rc)
(bitree-total bt))))
(multiple-value-bind
(c sum)
(bitree-find bt (floor (range-coder-low rc) temp))
(decf (range-coder-low rc)
(* sum temp))
(setf (range-coder-range rc)
(* (bitree-get bt c) temp))
(decode-normalize rc)
(arc-update bt c limit inc)
c)))
リスト : arc.asd (defsystem :arc :description "適応型 range coder" :version "0.1.0" :author "Makoto Hiroi" :license "MIT" :depends-on (:bitree :rangecoder) :in-order-to ((test-op (test-op :arc_tst))) :components ((:file "arc")))
;;;
;;; arc_tst.lisp : 適応型 rangecoder のテスト
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :arc_tst)
(defpackage :arc_tst (:use :cl :mintst :bitree :arc :rangecoder))
(in-package :arc_tst)
(export '(test))
(defvar bt nil)
(defvar rc nil)
(defun test ()
(initial)
(setq bt (bitree-initialize 8))
(call-with-byte-output-file
"rc_test.en"
(lambda (out)
(call-with-range-encoder
out
(lambda (r)
(setq rc r)
(run (arc-encode rc bt 0) nil)
(run (arc-encode rc bt 1) nil)
(run (arc-encode rc bt 2) nil)
(run (arc-encode rc bt 3) nil)
(run (arc-encode rc bt 4) nil)
(run (arc-encode rc bt 5) nil)
(run (arc-encode rc bt 6) nil)
(run (arc-encode rc bt 7) nil)))))
(setq bt (bitree-initialize 8))
(call-with-byte-input-file
"rc_test.en"
(lambda (in)
(call-with-range-decoder
in
(lambda (r)
(setq rc r)
(run (arc-decode rc bt) 0)
(run (arc-decode rc bt) 1)
(run (arc-decode rc bt) 2)
(run (arc-decode rc bt) 3)
(run (arc-decode rc bt) 4)
(run (arc-decode rc bt) 5)
(run (arc-decode rc bt) 6)
(run (arc-decode rc bt) 7)))))
(final))
リスト : arc_tst.asd (defsystem :arc_tst :description "test for arc" :version "0.1.0" :author "Makoto Hiroi" :license "MIT" :depends-on (:mintst :bitree :arc :rangecoder) :components ((:file "arc_tst")) :perform (test-op (o s) (symbol-call :arc_tst :test)))
;;;
;;; brc.lisp : 二値レンジコーダ
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :brc)
(defpackage :brc (:use :cl :rangecoder))
(in-package :brc)
(export '(bit-context
bit-context-p
make-bit-context
bit-encode
bit-decode
initialize-binary-model
binary-model-p
bm-encode
bm-decode
initialize-alpha-model
alpha-model-p
alpha-encode
alpha-decode
initialize-bits-model
bits-model-p
bits-encode
bits-decode
initialize-gamma-model
gamma-model-p
gamma-encode
gamma-decode
))
;;; ビットの出現頻度表
(defstruct bit-context (c0 1) (sum 2))
;;; 出現頻度表の更新
(defun bit-update (bc bit limit inc)
(incf (bit-context-sum bc) inc)
(when (zerop bit)
(incf (bit-context-c0 bc) inc))
(when (<= limit (bit-context-sum bc))
(setf (bit-context-c0 bc)
(logior (ash (bit-context-c0 bc) -1) 1)
(bit-context-sum bc)
(logior (ash (bit-context-sum bc) -1) 1))
(when (<= (bit-context-sum bc) (bit-context-c0 bc))
(setf (bit-context-sum bc) (1+ (bit-context-c0 bc))))))
;;; ビットの符号化
(defun bit-encode (rc bc bit &key (limit min-range) (inc 1))
(let* ((temp (floor (range-coder-range rc) (bit-context-sum bc)))
(n (* temp (bit-context-c0 bc))))
(cond ((plusp bit)
(incf (range-coder-low rc) n)
(decf (range-coder-range rc) n))
(t
(setf (range-coder-range rc) n)))
(encode-normalize rc)
(bit-update bc bit limit inc)))
;;; ビットの復号
(defun bit-decode (rc bc &key (limit min-range) (inc 1))
(let* ((temp (floor (range-coder-range rc) (bit-context-sum bc)))
(c0 (bit-context-c0 bc))
(n (* temp c0))
(bit 0))
(cond ((< (floor (range-coder-low rc) temp) c0)
(setf (range-coder-range rc) n))
(t
(setf bit 1)
(decf (range-coder-low rc) n)
(decf (range-coder-range rc) n)))
(decode-normalize rc)
(bit-update bc bit limit inc)
bit))
;;;
;;; binary-model
;;;
;;; 初期化
(defun initialize-bit-context-table (size)
(map-into (make-array size) #'make-bit-context))
;;; データ型
(defstruct binary-model size table)
;;; 初期化
(defun initialize-binary-model (size)
(make-binary-model :size size :table (initialize-bit-context-table (1- size))))
;;; 符号化
(defun bm-encode (rc bm c &key (limit min-range) (inc 1))
(labels ((encode-sub (node)
(when (plusp node)
(let* ((p (ash (1- node) -1))
(bc (aref (binary-model-table bm) p)))
(encode-sub p)
;; 奇数は左の子 (1), 偶数は右の子 (0)
(bit-encode rc bc (logand node 1) :limit limit :inc inc)))))
(encode-sub (+ c (binary-model-size bm) -1))))
;;; 復号
(defun bm-decode (rc bm &key (limit min-range) (inc 1))
(do ((node 0)
(node-size (1- (binary-model-size bm))))
((<= node-size node) (- node node-size))
(let* ((bc (aref (binary-model-table bm) node))
(bit (bit-decode rc bc :limit limit :inc inc)))
(if (plusp bit)
(setf node (+ (* node 2) 1))
(setf node (+ (* node 2) 2))))))
;;;
;;; alpha model
;;;
;;; データ型の定義
(defstruct alpha-model size table)
;;; 初期化
(defun initialize-alpha-model (size)
(make-alpha-model :size (1- size) :table (initialize-bit-context-table (1- size))))
;;; 符号化
(defun alpha-encode (rc am c &key (limit min-range) (inc 1))
(do ((n 0 (1+ n)))
((>= n (alpha-model-size am)))
(let ((bit (if (= n c) 1 0)))
(bit-encode rc (aref (alpha-model-table am) n) bit :limit limit :inc inc)
(when (plusp bit) (return)))))
;;; 復号
(defun alpha-decode (rc am &key (limit min-range) (inc 1))
(do ((c 0 (1+ c)))
((>= c (alpha-model-size am)) c)
(let ((bit (bit-decode rc (aref (alpha-model-table am) c) :limit limit :inc inc)))
(when (plusp bit) (return c)))))
;;;
;;; ビット列のモデル
;;;
(defstruct bits-model size table)
;;; 初期化
(defun initialize-bits-model (size)
(make-bits-model :size size :table (initialize-bit-context-table size)))
(defun bits-encode (rc bs c &key (limit min-range) (inc 1))
(dotimes (x (bits-model-size bs))
(let ((bit (logand (ash c (- x)) 1)))
(bit-encode rc (aref (bits-model-table bs) x) bit :limit limit :inc inc))))
(defun bits-decode (rc bs &key (limit min-range) (inc 1))
(do ((c 0)
(x 0 (1+ x)))
((>= x (bits-model-size bs)) c)
(let ((bit (bit-decode rc (aref (bits-model-table bs) x) :limit limit :inc inc)))
(when (plusp bit)
(setf c (logior (ash bit x) c))))))
;;;
;;; gamma model
;;;
(defstruct gamma-model size context1 context2)
(defun get-context-num (n)
(do ((n2 (ash n -1) (ash n2 -1))
(n1 0 (1+ n1)))
((<= n2 0) n1)))
(defun initialize-gamma-model (size)
(let* ((csize (get-context-num size))
(ct1 (initialize-alpha-model (1+ csize)))
(ct2 (make-array (1+ csize))))
(do ((x 1 (1+ x)))
((> x csize))
(setf (aref ct2 x) (initialize-bits-model x)))
(make-gamma-model :size size :context1 ct1 :context2 ct2)))
(defun gamma-encode (rc gm c)
(let ((n (get-context-num (1+ c))))
(alpha-encode rc (gamma-model-context1 gm) n)
(when (plusp n)
(bits-encode rc (aref (gamma-model-context2 gm) n) (1+ c)))))
(defun gamma-decode (rc gm)
(let ((n1 (alpha-decode rc (gamma-model-context1 gm))))
(if (zerop n1)
n1
(let ((n2 (bits-decode rc (aref (gamma-model-context2 gm) n1))))
(+ (ash 1 n1) n2 -1)))))
リスト : brc.asd (defsystem :brc :description "binary range coder" :version "0.1.0" :author "Makoto Hiroi" :license "MIT" :depends-on (:rangecoder) :in-order-to ((test-op (test-op :brc_tst))) :components ((:file "brc")))
;;;
;;; brc_tst.lisp : binary range coder のテスト
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :brc_tst)
(defpackage :brc_tst (:use :cl :mintst :brc :rangecoder))
(in-package :brc_tst)
(export '(test))
(defvar bc nil)
(defvar rc nil)
(defvar bm nil)
(defvar am nil)
(defvar bs nil)
(defvar gm nil)
(defun test ()
(initial)
(run (bit-context-p (setq bc (make-bit-context))) t)
(call-with-byte-output-file
"brc_test.en"
(lambda (out)
(call-with-range-encoder
out
(lambda (r)
(setq rc r)
(run (bit-encode rc bc 0) nil)
(run (bit-encode rc bc 1) nil)
(run (bit-encode rc bc 0) nil)
(run (bit-encode rc bc 0) nil)
(run (bit-encode rc bc 1) nil)
(run (bit-encode rc bc 1) nil)
(run (bit-encode rc bc 1) nil)
(run (bit-encode rc bc 0) nil)))))
(setq bc (make-bit-context))
(call-with-byte-input-file
"brc_test.en"
(lambda (in)
(call-with-range-decoder
in
(lambda (r)
(setq rc r)
(run (bit-decode rc bc) 0)
(run (bit-decode rc bc) 1)
(run (bit-decode rc bc) 0)
(run (bit-decode rc bc) 0)
(run (bit-decode rc bc) 1)
(run (bit-decode rc bc) 1)
(run (bit-decode rc bc) 1)
(run (bit-decode rc bc) 0)))))
;; binary model のテスト
(run (binary-model-p (setq bm (initialize-binary-model 8))) t)
(call-with-byte-output-file
"bm_test.en"
(lambda (out)
(call-with-range-encoder
out
(lambda (r)
(setq rc r)
(run (bm-encode rc bm 0) nil)
(run (bm-encode rc bm 1) nil)
(run (bm-encode rc bm 2) nil)
(run (bm-encode rc bm 3) nil)
(run (bm-encode rc bm 4) nil)
(run (bm-encode rc bm 5) nil)
(run (bm-encode rc bm 6) nil)
(run (bm-encode rc bm 7) nil)))))
(setq bm (initialize-binary-model 8))
(call-with-byte-input-file
"bm_test.en"
(lambda (in)
(call-with-range-decoder
in
(lambda (r)
(setq rc r)
(run (bm-decode rc bm) 0)
(run (bm-decode rc bm) 1)
(run (bm-decode rc bm) 2)
(run (bm-decode rc bm) 3)
(run (bm-decode rc bm) 4)
(run (bm-decode rc bm) 5)
(run (bm-decode rc bm) 6)
(run (bm-decode rc bm) 7)))))
;; alpha model のテスト
(run (alpha-model-p (setq am (initialize-alpha-model 8))) t)
(call-with-byte-output-file
"am_test.en"
(lambda (out)
(call-with-range-encoder
out
(lambda (r)
(setq rc r)
(run (alpha-encode rc am 0) nil)
(run (alpha-encode rc am 1) nil)
(run (alpha-encode rc am 2) nil)
(run (alpha-encode rc am 3) nil)
(run (alpha-encode rc am 4) nil)
(run (alpha-encode rc am 5) nil)
(run (alpha-encode rc am 6) nil)
(run (alpha-encode rc am 7) nil)))))
(setq am (initialize-alpha-model 8))
(call-with-byte-input-file
"am_test.en"
(lambda (in)
(call-with-range-decoder
in
(lambda (r)
(setq rc r)
(run (alpha-decode rc am) 0)
(run (alpha-decode rc am) 1)
(run (alpha-decode rc am) 2)
(run (alpha-decode rc am) 3)
(run (alpha-decode rc am) 4)
(run (alpha-decode rc am) 5)
(run (alpha-decode rc am) 6)
(run (alpha-decode rc am) 7)))))
;; bits model のテスト
(run (bits-model-p (setq bs (initialize-bits-model 3))) t)
(call-with-byte-output-file
"bs_test.en"
(lambda (out)
(call-with-range-encoder
out
(lambda (r)
(setq rc r)
(run (bits-encode rc bs 0) nil)
(run (bits-encode rc bs 1) nil)
(run (bits-encode rc bs 2) nil)
(run (bits-encode rc bs 3) nil)
(run (bits-encode rc bs 4) nil)
(run (bits-encode rc bs 5) nil)
(run (bits-encode rc bs 6) nil)
(run (bits-encode rc bs 7) nil)))))
(setq bs (initialize-bits-model 3))
(call-with-byte-input-file
"bs_test.en"
(lambda (in)
(call-with-range-decoder
in
(lambda (r)
(setq rc r)
(run (bits-decode rc bs) 0)
(run (bits-decode rc bs) 1)
(run (bits-decode rc bs) 2)
(run (bits-decode rc bs) 3)
(run (bits-decode rc bs) 4)
(run (bits-decode rc bs) 5)
(run (bits-decode rc bs) 6)
(run (bits-decode rc bs) 7)))))
;; gamma model のテスト
(run (gamma-model-p (setq gm (initialize-gamma-model 256))) t)
(call-with-byte-output-file
"gm_test.en"
(lambda (out)
(call-with-range-encoder
out
(lambda (r)
(setq rc r)
(run (gamma-encode rc gm 0) nil)
(run (gamma-encode rc gm 15) nil)
(run (gamma-encode rc gm 16) nil)
(run (gamma-encode rc gm 31) nil)
(run (gamma-encode rc gm 32) nil)
(run (gamma-encode rc gm 63) nil)
(run (gamma-encode rc gm 64) nil)
(run (gamma-encode rc gm 255) nil)))))
(setq gm (initialize-gamma-model 256))
(call-with-byte-input-file
"gm_test.en"
(lambda (in)
(call-with-range-decoder
in
(lambda (r)
(setq rc r)
(run (gamma-decode rc gm) 0)
(run (gamma-decode rc gm) 15)
(run (gamma-decode rc gm) 16)
(run (gamma-decode rc gm) 31)
(run (gamma-decode rc gm) 32)
(run (gamma-decode rc gm) 63)
(run (gamma-decode rc gm) 64)
(run (gamma-decode rc gm) 255)))))
(final))
リスト : brc_tst.asd (defsystem :brc_tst :description "test for brc" :version "0.1.0" :author "Makoto Hiroi" :license "MIT" :depends-on (:mintst :brc :rangecoder) :components ((:file "brc_tst")) :perform (test-op (o s) (symbol-call :brc_tst :test)))