\ scan color QR codes on Android
\ Copyright (C) 2016-2018 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/>.
\ scan matrix manipulation
Create scan-matrix
1.0e sf, 0.0e sf, 0.0e sf, 0.0e sf,
0.0e sf, 1.0e sf, 0.0e sf, 0.0e sf,
0.0e sf, 0.0e sf, 1.0e sf, 0.0e sf,
0.0e sf, 0.0e sf, 0.0e sf, 1.0e sf,
32 sfloats buffer: scan-inverse
20.0e FValue x-scansize
20.75e FValue y-scansize
0.5e FValue y-offset
0.0e FValue x-offset
\ matrix inversion
' dfloats alias 8*
: .mat { mat -- }
4 0 DO cr
8 0 DO
mat J 8* I + sfloats + sf@ f.
LOOP
LOOP ;
: init-scan' ( -- )
scan-inverse [ 32 sfloats ]L 2dup erase bounds ?DO
1e fdup I sf! I [ 4 sfloats ]L + sf!
[ 9 sfloats ]L +LOOP ;
: sfax+y8 ( ra addr1 addr2 -- )
[ 8 sfloats ]L bounds ?DO
dup sf@ fover I sf@ f* f+ dup sf! sfloat+
[ 1 sfloats ]L +LOOP drop fdrop ;
: sfax8 ( ra addr -- )
[ 8 sfloats ]L bounds ?DO
fdup I sf@ f* I sf!
[ 1 sfloats ]L +LOOP fdrop ;
: tij8 ( addr1 addr2 -- )
[ 8 sfloats ]L bounds ?DO
dup sf@ I sf@ dup sf! I sf! sfloat+
[ 1 sfloats ]L +LOOP drop ;
: matrix-invert4 { mat -- } \ shortcut to invert typical matrix
mat sf@ fabs mat [ 8 sfloats ]L + sf@ fabs f< IF
mat dup [ 8 sfloats ]L + tij8 \ exchange two lines
THEN
4 0 DO
4 0 DO
mat J [ 9 sfloats ]L * + sf@ 1/f
I J <> IF
mat I 8* sfloats +
mat J 8* sfloats +
over J sfloats + sf@ f* fnegate sfax+y8
ELSE
mat J 8* sfloats + sfax8
THEN
( mat .mat cr ) \ debugging output
LOOP
LOOP ;
scan-inverse 0 sfloats + Constant x-scale
scan-inverse 1 sfloats + Constant y-rots
scan-inverse 8 sfloats + Constant x-rots
scan-inverse 9 sfloats + Constant y-scale
scan-inverse 24 sfloats + Constant x-spos
scan-inverse 25 sfloats + Constant y-spos
: >scan-matrix ( -- )
scan-inverse matrix-invert4
scan-matrix [ scan-inverse 4 sfloats + ]L [ 32 sfloats ]L bounds ?DO
I over [ 4 sfloats ]L move [ 4 sfloats ]L +
[ 8 sfloats ]L +LOOP drop ;
$40 Value scan-w
scan-w dup * 1- 2/ 1+ Constant buf-len
also opengl also android
: v2scale ( x y scale -- ) ftuck f* frot frot f* fswap ;
: draw-scan ( direction -- )
\G draw a scan rotated by rangle
v0 i0 >v
1e fdup fnegate { f: s f: -s }
-s s >xy n> rot>st $000000FF rgba>c v+
s s >xy n> rot>st $000000FF rgba>c v+
s -s >xy n> rot>st $000000FF rgba>c v+
-s -s >xy n> rot>st $000000FF rgba>c v+
v> drop 0 i, 1 i, 2 i, 0 i, 2 i, 3 i,
GL_TRIANGLES draw-elements ;
: scan-frame0 ( -- )
0e fdup x-pos sf! >y-pos
unit-matrix MVMatrix set-matrix 0 draw-scan ;
Variable scan-buf0
Variable scan-buf1
Variable red-buf
Variable green-buf
Variable blue-buf
$E8 Value blue-level#
$B0 Value green-level#
$B0 Value red-level#
: extract-buf ( offset buf level -- ) { level }
buf-len over $!len
$@ drop swap
scan-buf1 $@ >r + r> bounds ?DO 0
I 8 sfloats bounds DO
2* I c@ level u< -
cell +LOOP over c! 1+
8 sfloats +LOOP drop ;
: extract-red ( -- ) 0 red-buf red-level# extract-buf ;
: extract-green ( -- ) 1 green-buf green-level# extract-buf ;
: extract-blue ( -- ) 2 blue-buf blue-level# extract-buf ;
: .buf ( addr -- )
[: 0 swap $@ bounds ?DO cr
dup 3 .r space 1+
I scan-w 2 rshift bounds ?DO
I c@ 0 <# # # #> type
LOOP
scan-w 2 rshift +LOOP drop ;] $10 base-execute ;
: .red ( -- ) red-buf .buf ;
: .green ( -- ) green-buf .buf ;
: .blue ( -- ) blue-buf .buf ;
: mixgr>32 ( 16red 16green -- 32result )
0 $10 0 DO
2* 2*
over $E rshift 2 and or >r
over $F rshift 1 and r> or >r
2* swap 2* swap r>
LOOP nip nip ;
$51 buffer: guessbuf
guessbuf $40 + Constant guessecc
guessecc $10 + Constant guesstag
scan-w 2 rshift constant scan-step
scan-step dup scan-w 9 - * swap 2/ 1- + Constant scan-top
scan-step dup scan-w 7 + * swap 2/ 1- + Constant scan-bot
scan-step dup scan-w 8 + * swap 2/ 1- + Constant scan-ecc
: ecc-hor@ ( off -- w1 w2 ) >r
red-buf $@ drop r@ + be-uw@
green-buf $@ drop r> + be-uw@ mixgr>32 ;
: >guess ( -- addr u )
guessbuf
scan-top scan-bot DO
I ecc-hor@ over be-l! 4 +
scan-step -LOOP
drop guessbuf $40 ;
: tag1@ { addr bit -- tag }
addr red-buf $@ drop + c@ bit rshift 1 and
addr green-buf $@ drop + c@ bit rshift 1 and 2* or ;
: ecc-ver@ { off bit -- ul } 0
scan-top scan-bot DO
2* 2* I off + bit tag1@ or
scan-step -LOOP ;
: tag2@ ( addr -- )
dup 1- 0 tag1@ 2 lshift swap 2 + 7 tag1@ or ;
: tag@ ( -- tag )
scan-ecc tag2@ 4 lshift
scan-top tag2@ or ;
: >guessecc ( -- )
scan-ecc ecc-hor@ guessecc be-l!
scan-top ecc-hor@ guessecc 4 + be-l!
-1 0 ecc-ver@ guessecc 8 + be-l!
2 7 ecc-ver@ guessecc $C + be-l! ;
: ecc-ok? ( addrkey u1 addrecc u2 -- flag )
msg( ." ecc? " 2over xtype space 2dup xtype space x-scansize f. y-scansize f. x-offset f. y-offset f. cr )
2dup + c@ taghash? ;
: |min| ( a b -- ) over abs over abs < select ;
$8000 Constant init-xy
: get-minmax ( addr u -- min max )
$FF $00 2swap
bounds ?DO
I c@ tuck umax >r umin r>
4 +LOOP ;
: get-minmax-rgb ( -- minr maxr ming maxg minb maxb )
scan-buf1 $@ swap 3 bounds DO
I over get-minmax rot
LOOP drop ;
: search-corner { mask -- x y } init-xy dup { x y }
scan-buf0 $@ drop
scan-w dup negate DO
scan-w dup negate DO
dup c@ red-level# u< 1 and
over 1+ c@ green-level# u< 2 and or
over 2 + c@ blue-level# u< 4 and or
mask = IF
I dup * J dup * +
x dup * y dup * + u< IF
I to x J to y
THEN
THEN
sfloat+
LOOP
LOOP drop x y ;
2Variable p0 \ top left
2Variable p1 \ top right
2Variable p2 \ bottom left
2Variable p3 \ bottom right
2Variable px ( cross of the two lines )
: search-corners ( -- )
\ get-minmax-rgb . . . . . . cr
4 search-corner p0 2! \ top left
5 search-corner p1 2! \ top right
6 search-corner p2 2! \ bottom left
7 search-corner p3 2! \ bottom right
;
: ?legit ( -- flag )
p0 2@ init-xy dup d<>
p1 2@ init-xy dup d<> and
p2 2@ init-xy dup d<> and
p3 2@ init-xy dup d<> and ;
: compute-xpoint ( -- rx ry )
p0 2@ s>f s>f { f: y0 f: x0 }
p3 2@ s>f s>f { f: y1 f: x1 }
p1 2@ s>f s>f { f: y2 f: x2 }
p2 2@ s>f s>f { f: y3 f: x3 }
x0 y1 f* y0 x1 f* f- { f: dxy01 }
x2 y3 f* y2 x3 f* f- { f: dxy23 }
x0 x1 f- y2 y3 f- f* y0 y1 f- x2 x3 f- f* f- 1/f { f: det1 }
dxy01 x2 x3 f- f* dxy23 x0 x1 f- f* f- det1 f* { f: x }
dxy01 y2 y3 f- f* dxy23 y0 y1 f- f* f- det1 f* { f: y }
x f>s y f>s px 2! x y ;
: p+ ( x1 y1 x2 y2 -- x1+x2 y1+y2 )
rot + >r + r> ;
: p2* ( x1 y1 -- x2 y2 )
2* swap 2* swap ;
: p2/ ( x1 y1 -- x2 y2 )
2/ swap 2/ swap ;
: p- ( x1 y1 x2 y2 -- x1-x2 y1-y2 )
rot swap - >r - r> ;
: scan-grab-buf ( addr -- )
>r 0 0 scan-w 2* dup
2dup * sfloats r@ $!len
GL_RGBA GL_UNSIGNED_BYTE r> $@ drop glReadPixels ;
: scan-grab0 ( -- ) scan-buf0 scan-grab-buf ;
: scan-grab1 ( -- ) scan-buf1 scan-grab-buf ;
: .xpoint ( x y -- )
p0 2@ swap . . space
p1 2@ swap . . space
p2 2@ swap . . space
p3 2@ swap . . space
fswap f. f. cr ;
tex: scan-tex
0 Value scan-fb
: new-scantex ( -- )
scan-tex 0e 0e 0e 1e glClearColor
scan-w 2* dup GL_RGBA new-textbuffer to scan-fb ;
: scale+rotate ( -- )
p1 2@ p0 2@ p- p3 2@ p2 2@ p- p+ p2/
s>f y-scansize f/ y-rots sf! s>f x-scansize f/ x-scale sf!
p0 2@ p2 2@ p- p1 2@ p3 2@ p- p+ p2/
s>f y-scansize f/ y-scale sf! s>f x-scansize f/ x-rots sf! ;
: set-scan' ( -- )
compute-xpoint ( .. x y )
scale+rotate
y-offset f+ scan-w fm/ y-spos sf!
x-offset f+ scan-w fm/ x-spos sf! ;
: scan-legit ( -- ) \ resize a legit QR code
init-scan' set-scan' >scan-matrix
scan-matrix MVPMatrix set-matrix
scan-matrix MVMatrix set-matrix clear
0 draw-scan scan-grab1 ;
: visual-frame ( -- )
oes-program init
unit-matrix MVPMatrix set-matrix
unit-matrix MVMatrix set-matrix
media-tex nearest-oes
screen-orientation draw-scan sync ;
: scan-legit? ( -- addr u flag )
scan-legit extract-red extract-green >guess
>guessecc tag@ guesstag c!
2dup guessecc $10 ecc-ok? ;
: scan-legits? ( -- addr u flag )
5 0 DO
I s>f f2/ f2/ to y-offset
85 80 DO I s>f f2/ f2/ to y-scansize
scan-legit? IF unloop unloop true EXIT THEN
2drop
LOOP
LOOP 0 0 false ;