qr.fs 5.47 KB
Newer Older
bernd's avatar
bernd committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
\ net2o QR code

\ Copyright (C) 2015   Bernd Paysan

\ This program is free software: you can redistribute it and/or modify
\ it under the terms of the GNU Affero General Public License as published by
\ the Free Software Foundation, either version 3 of the License, or
\ (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU Affero General Public License for more details.

\ You should have received a copy of the GNU Affero General Public License
\ along with this program.  If not, see <http://www.gnu.org/licenses/>.

18
require tools.fs
bernd's avatar
bernd committed
19

bernd's avatar
bernd committed
20 21
\ unicode characters to display a color matrix

22
e? max-xchar $100 < [IF] '^' [ELSE] '' [THEN] Constant upper-half-block
bernd's avatar
bernd committed
23 24 25
\ '' Constant lower-half-block
\ '' Constant solid-block

bernd's avatar
bernd committed
26 27 28
\ constants

24 Constant keyqr# \ key qr codes are 24x24 blocks
Bernd Paysan's avatar
Bernd Paysan committed
29
keyqr# dup * Constant keyqr#² \ code block size
bernd's avatar
bernd committed
30
$40 Constant keymax#
bernd's avatar
bernd committed
31 32
4 Constant keyline#
8 Constant keylineskp#
bernd's avatar
bernd committed
33

Bernd Paysan's avatar
Bernd Paysan committed
34 35
keyqr#² buffer: keyqr \ code block buffer
keyqr#² sfloats buffer: keyqr-rgba \ code block in RGBA
36
$10 buffer: qrecc
bernd's avatar
bernd committed
37

38 39 40 41 42 43 44 45 46 47
Defer <rest>  ' <white> is <rest>
$8 Value 2b>col

: white-qr ( -- )
    ['] <white> is <rest>
    $8 to 2b>col ;
: black-qr ( -- )
    ['] <black> is <rest>
    $F to 2b>col ;

bernd's avatar
bernd committed
48
\ : half-blocks ( n -- ) 0 ?DO  upper-half-block xemit  LOOP ;
Bernd Paysan's avatar
Bernd Paysan committed
49
\ : blocks ( n -- ) 0 U+DO solid-block xemit LOOP ;
bernd's avatar
bernd committed
50
: .prelines ( -- )
bernd's avatar
bernd committed
51
    rows keyqr# 2/ - 2/ 0 ?DO
bernd's avatar
bernd committed
52
	\ [ red >fg green >bg or ]L attr!
53
	<rest> cols spaces <default> cr  LOOP ;
bernd's avatar
bernd committed
54
: .preline ( -- )
bernd's avatar
bernd committed
55
    \ [ red >fg green >bg or ]L attr!
56
    <rest> cols keyqr# - 2/ spaces ;
bernd's avatar
bernd committed
57 58
: qr.2lines ( addr u -- ) .preline
    tuck bounds ?DO
59
	I c@ over I + c@ 2b>col xor >bg swap 2b>col xor >fg or attr!
bernd's avatar
bernd committed
60 61 62 63 64 65 66
	upper-half-block xemit
    LOOP  drop .preline ;
: qr.block ( addr u -- ) .prelines
    tuck dup * bounds ?DO
	I over qr.2lines <default> cr
    dup 2* +LOOP  drop .prelines ;

bernd's avatar
bernd committed
67 68 69 70
: 4xc! ( c addr -- )
    2dup c! 2dup 1+ c!  keyqr# +
    2dup c! 1+ c! ;

bernd's avatar
bernd committed
71
: >keyframe ( -- )  keyqr keyqr#² erase
72 73 74 75
    $04 [ keyqr                        ]L 4xc!
    $05 [ keyqr keyqr# + 2 -           ]L 4xc!
    $06 [ keyqr keyqr#² + keyqr# 2* -  ]L 4xc!
    $07 [ keyqr keyqr#² + keyqr# - 2 - ]L 4xc! ;
76 77 78 79 80 81 82 83
: byte>pixel ( byte addr dist -- )
    \ a byte is converted into four pixels:
    \ MSB green red | green red | green red | green red LSB
    >r
    over 6 rshift       over c! r@ +
    over 4 rshift 3 and over c! r@ +
    over 2 rshift 3 and over c! r> +
    swap          3 and swap c! ;
84
: byte>hpixel ( byte addr -- )
bernd's avatar
bernd committed
85 86
    \ a byte is converted into four pixels:
    \ MSB green red | green red | green red | green red LSB
87
    1 byte>pixel ;
88 89 90
: byte>vpixel ( byte addr -- )
    \ a byte is converted into four pixels:
    \ MSB green red | green red | green red | green red LSB
91
    keyqr# byte>pixel ;
bernd's avatar
bernd committed
92

93 94 95 96
: >keyhline ( destaddr srcaddr -- destaddr' )
    keyline# bounds ?DO  I c@ over byte>hpixel 4 +  LOOP ;
: >keyvline ( destaddr srcaddr -- destaddr' )
    keyline# bounds ?DO  I c@ over byte>vpixel [ keyqr# 4 * ]L +  LOOP ;
bernd's avatar
bernd committed
97
: >keylines ( addr u -- )
98 99
    keyqr [ keyqr# 1+ 2* 2* ]L + -rot keymax# umin bounds ?DO
	I >keyhline  keylineskp# +
bernd's avatar
bernd committed
100 101
    keyline# +LOOP  drop ;

Bernd Paysan's avatar
Bernd Paysan committed
102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
\ qr to RGBA

Create >rgba
$00000000 ,
$FF000000 ,
$00FF0000 ,
$FFFF0000 ,
$0000FF00 ,
$FF00FF00 ,
$00FFFF00 ,
$FFFFFF00 ,
$000000FF ,
$FF0000FF ,
$00FF00FF ,
$FFFF00FF ,
$0000FFFF ,
$FF00FFFF ,
$00FFFFFF ,
$FFFFFFFF ,

: qr>rgba ( -- )
    keyqr-rgba keyqr keyqr#² bounds DO
	I c@ 2b>col xor 7 xor cells >rgba + @ over be-l! sfloat+
    LOOP drop ;

127 128
\ generate checksum and tag bits

bernd's avatar
bernd committed
129 130 131
: >qr-key ( addr u -- ) qr-key keysize move-rep ;
: rng>qr-key ( -- )  $8 rng$ >qr-key ;
: date>qr-key ( -- )  sigdate $8 >qr-key ;
bernd's avatar
bernd committed
132
: taghash-rest ( addr1 u1 addrchallenge u2 tag -- tag )  >r
133 134
    c:0key $8 umin qrecc $8 smove r@ qrecc $8 + c!
    qrecc $9 c:shorthash c:shorthash qrecc $8 + $8 c:hash@ r>
bernd's avatar
bernd committed
135
    msg( ." ecc= " qrecc $10 xtype space dup hex. cr ) ;
136
: >taghash ( addr u tag -- tag )
bernd's avatar
bernd committed
137
    qr-key $8 rot taghash-rest ;
138
: taghash? ( addr u1 ecc u2 tag -- flag )
bernd's avatar
bernd committed
139 140
    >r 2tuck over $8 >qr-key
    r> taghash-rest drop 8 /string qrecc 8 + 8 str= ;
141
: >ecc ( addr u tag -- ) >taghash
Bernd Paysan's avatar
Bernd Paysan committed
142
    qr( ." ecc: " qrecc $10 xtype cr )
143 144 145 146
    keyqr [ keyqr# #03 *  #4 + ]L +  qrecc      >keyhline drop
    keyqr [ keyqr# #20 *  #4 + ]L +  qrecc $4 + >keyhline drop
    keyqr [ keyqr# #04 *  #3 + ]L +  qrecc $8 + >keyvline drop
    keyqr [ keyqr# #04 * #20 + ]L +  qrecc $C + >keyvline drop
147 148 149
    dup 6 rshift       keyqr [ keyqr#  #3 *  #3 + ]L + c!
    dup 4 rshift 3 and keyqr [ keyqr#  #3 * #20 + ]L + c!
    dup 2 rshift 3 and keyqr [ keyqr# #20 *  #3 + ]L + c!
bernd's avatar
bernd committed
150
    ( )          3 and keyqr [ keyqr# #20 * #20 + ]L + c! ;
151

bernd's avatar
bernd committed
152
: .qr-rest ( addr u tag -- )
153 154
    >r >keyframe 2dup >keylines r> >ecc
    keyqr keyqr# qr.block ;
bernd's avatar
bernd committed
155

bernd's avatar
bernd committed
156
: .keyqr ( addr u tag -- ) \ 64 bytes
Bernd Paysan's avatar
Bernd Paysan committed
157 158
    qr( >r 2dup bounds U+DO ." qr : " I $10 xtype cr $10 +LOOP
    r> ." tag: " dup hex. cr )
bernd's avatar
bernd committed
159 160 161 162 163
    rng>qr-key .qr-rest ;

: .sigqr ( addr u -- ) \ any string
    c:0key c:hash now>never sigdate +date
    sig-params ed-sign
164
    date>qr-key qr:keysig# .qr-rest ;
bernd's avatar
bernd committed
165

166
\\\
bernd's avatar
bernd committed
167 168 169 170 171 172 173 174 175 176 177 178 179
Local Variables:
forth-local-words:
    (
     (("net2o:" "+net2o:") definition-starter (font-lock-keyword-face . 1)
      "[ \t\n]" t name (font-lock-function-name-face . 3))
     ("[a-z0-9]+(" immediate (font-lock-comment-face . 1)
      ")" nil comment (font-lock-comment-face . 1))
    )
forth-local-indent-words:
    (
     (("net2o:" "+net2o:") (0 . 2) (0 . 2) non-immediate)
    )
End:
Bernd Paysan's avatar
Bernd Paysan committed
180
[THEN]