Artifact
f523328eb89b3c1e53a46f070e214b3fd4c486dd:
- File
qrscan.fs
— part of check-in
[531f5bc61f]
at
2019-01-16 17:45:30
on branch trunk
— Replace 0 [IF] for emacs editings with \\\
(user:
bernd
size: 13021)
\ 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/>.
require minos2/gl-helper.fs
[IFDEF] android
require minos2/android-recorder.fs
[ELSE]
[IFUNDEF] cam-w
$100 value cam-w
$100 value cam-h
[THEN]
[THEN]
\ replace some tools available under net2o
[IFUNDEF] qr(
debug: qr(
+db qr( \ turn it on )
[THEN]
[IFUNDEF] xtype
: hex[ ]] [: [[ ; immediate
: ]hex ]] ;] $10 base-execute [[ ; immediate
: xtype ( addr u -- ) hex[
bounds ?DO I c@ 0 <# # # #> type LOOP ]hex ;
[THEN]
[IFUNDEF] taghash?
: taghash? ( addrkey u1 addrecc u2 tag -- flag )
drop 2drop 2drop true ;
[THEN]
\ scan matrix manipulation
Create scan-matrix
1e sf, 0e sf, 0e sf, 0e sf,
0e sf, 1e sf, 0e sf, 0e sf,
0e sf, 0e sf, 1e sf, 0e sf,
0e sf, 0e sf, 0e sf, 1e sf,
scan-matrix 11 sfloats + Constant 3d-enabler
32 sfloats buffer: scan-inverse
32 sfloats buffer: inverse-default
inverse-default 32 sfloats bounds
[?DO] 1e fdup [I] sf! [I] 4 sfloats + sf! 9 sfloats [+LOOP]
83e FValue x-scansize
83e FValue y-scansize
0e FValue y-offset
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' ( -- )
inverse-default scan-inverse [ 32 sfloats ]L move ;
: 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-scl
scan-inverse 1 sfloats + Constant y-rots
scan-inverse 8 sfloats + Constant x-rots
scan-inverse 9 sfloats + Constant y-scl
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
-1e 3d-enabler sf! ;
\ scan constants
$40 Value scan-w
scan-w 2/ dup * 1- 2/ 2/ 1+ Constant buf-len
scan-w 2* Value scan-right
scan-w 2* dup 3 rshift + negate Value scan-left
also opengl
: draw-scan ( direction xscale yscale -- )
\G draw a scan rotated/tilted by scan matrix
fover fnegate fover fnegate 0e { f: sx f: sy f: -sx f: -sy f: z }
vi0 >v
-sx sy z >xyz n> rot>st white# i>c v+
sx sy z >xyz n> rot>st white# i>c v+
sx -sy z >xyz n> rot>st white# i>c v+
-sx -sy z >xyz n> rot>st white# i>c v+
v> drop 0 i, 1 i, 2 i, 0 i, 2 i, 3 i,
GL_TRIANGLES draw-elements ;
Variable scan-buf-raw
Variable scan-buf0
Variable scan-buf1
Variable red-buf
Variable green-buf
Variable blue-buf
$28 Value blue-level#
$70 Value green-level#
$70 Value red-level#
' sfloats alias rgbas ( one rgba is the size of an sfloat )
' sfloat+ alias rgba+
[IFDEF] distdebug
3 cells buffer: dist0
dist0 cell+ Constant dist0-max
dist0-max cell+ Constant dist0-min
3 cells buffer: dist1
dist1 cell+ Constant dist1-max
dist1-max cell+ Constant dist1-min
: ?? ( value level -- flag )
- dup dup 0< IF negate dist0 ELSE dist1 THEN
2dup +! cell+
2dup @ umax over ! cell+
tuck @ umin swap !
0< ;
[ELSE]
' < alias ??
[THEN]
: rgb@ ( addr -- r g b )
>r r@ c@ r@ 1+ c@ r> 2 + c@ ;
0 Value rgb-xor
: rgb? ( addr -- rgbbit )
rgb@
blue-level# ?? negate 2* swap
green-level# ?? - 2* swap
red-level# ?? - rgb-xor xor ;
: extract-strip ( addr u step -- strip ) rgbas { step }
0 -rot bounds U+DO
2* 2* I rgb? 3 and +
step +LOOP ;
$51 buffer: guessbuf
guessbuf $40 + Constant guessecc
guessecc $10 + Constant guesstag
scan-w 3 rshift Constant scan-step
: >strip ( index --- addr )
2* 2* scan-w + scan-w 2* * scan-w + rgbas
scan-buf1 $@ rot safe/string drop ;
: >strip32 ( addr -- addr' u step )
scan-right - $100 4 ;
: >guess ( -- addr u )
guessbuf $40 2dup bounds -8 -rot U+DO
dup >strip >strip32
extract-strip I be-l!
1+
4 +LOOP drop ;
: ecc-hor@ ( off -- l )
>strip >strip32 extract-strip ;
: ecc-ver@ ( offset -- ul )
#-8 >strip + scan-w dup 3 lshift * scan-w 3 lshift extract-strip ;
: tag@ ( -- tag )
#-9 >strip scan-left + $130 [ #17 4 * ]L extract-strip 4 lshift
#08 >strip scan-left + $130 [ #17 4 * ]L extract-strip or ;
: >guessecc ( -- )
#-9 ecc-hor@ guessecc be-l!
#08 ecc-hor@ guessecc 4 + be-l!
scan-left ecc-ver@ guessecc 8 + be-l!
scan-right ecc-ver@ guessecc $C + be-l! ;
: ecc-ok? ( addrkey u1 addrecc u2 -- flag )
2dup + c@ taghash? ;
$8000 Constant init-xy
: get-minmax-rgb ( addr u -- minr maxr ming maxg minb maxb )
$FFF -$FFF 2dup 2dup { minr maxr ming maxg minb maxb }
bounds ?DO
I rgb@
dup maxb max to maxb minb min to minb
dup maxg max to maxg ming min to ming
dup maxr max to maxr minr min to minr
4 +LOOP minr maxr ming maxg minb maxb ;
#10 Cells buffer: p0
p0 2 cells + Constant p1
p1 2 cells + Constant p2
p2 2 cells + Constant p3
p3 2 cells + Constant px
: min²! ( x y addr -- ) >r
over dup * over dup * +
r@ 2@ dup * swap dup * + u< IF
r> 2! EXIT
THEN 2drop rdrop ;
: search-corners ( -- )
init-xy p0 ! p0 p0 cell+ 7 cells cmove \ fill all with the same contents
scan-buf0 $@ drop
scan-w dup negate DO
scan-w dup negate DO
dup rgb? dup 4 and IF 3 and 2 xor
2* cells p0 + I J rot min²!
ELSE
drop
THEN
rgba+
LOOP
LOOP drop ;
: ?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- x2 x3 f- { f: dx01 f: dx23 }
y0 y1 f- y2 y3 f- { f: dy01 f: dy23 }
dx01 dy23 f* dy01 dx23 f* f- 1/f { f: /det1 }
dxy01 dx23 f* dxy23 dx01 f* f- /det1 f* \ x
dxy01 dy23 f* dxy23 dy01 f* f- /det1 f* \ y
fover f>s fdup f>s px 2! ;
: p+ ( x1 y1 x2 y2 -- x1+x2 y1+y2 )
rot + >r + r> ;
: p2/ ( x1 y1 -- x2 y2 )
2/ swap 2/ swap ;
: p- ( x1 y1 x2 y2 -- x1-x2 y1-y2 )
rot swap - >r - r> ;
: scan-grab ( w h addr -- )
>r 0 0 2swap
2dup * rgbas r@ $!len
GL_RGBA GL_UNSIGNED_BYTE r> $@ drop glReadPixels ;
: scan-grab-buf ( addr -- )
scan-w 2* dup rot scan-grab ;
: scan-grab-cam ( addr -- )
cam-w cam-h rot scan-grab ;
tex: scan-tex-raw
tex: scan-tex
tex: scan-tex-final
0 Value scan-fb-raw
0 Value scan-fb
0 Value scan-fb-final
: scan-grab-raw ( -- )
cam-w cam-h scan-fb-raw >framebuffer scan-buf-raw scan-grab-cam ;
: scan-grab0 ( -- )
scan-buf0 scan-grab-buf ;
: scan-grab1 ( -- )
scan-buf1 scan-grab-buf ;
also soil
0 Value scan#
: save-png0 ( -- )
[: ." scanimg0-" scan# 0 .r ." .png" ;] $tmp
SOIL_SAVE_TYPE_PNG 128 dup 4 scan-buf0 $@ drop SOIL_save_image ;
: save-png1 ( -- )
[: ." scanimg1-" scan# 0 .r ." .png" ;] $tmp
SOIL_SAVE_TYPE_PNG 128 dup 4 scan-buf1 $@ drop SOIL_save_image ;
: save-png-raw ( -- )
[: ." scanimgraw-" scan# 0 .r ." .png" ;] $tmp
SOIL_SAVE_TYPE_PNG cam-w cam-h 4 scan-buf-raw $@ drop SOIL_save_image ;
: save-pngs ( -- )
scan-grab-raw save-png-raw
save-png0 save-png1
1 +to scan#
0>framebuffer ;
previous
: .xpoint ( x y -- )
p0 2@ swap . . space
p1 2@ swap . . space
p2 2@ swap . . space
p3 2@ swap . . space
fswap f. f. cr ;
: new-scantex-raw ( -- )
scan-tex-raw 0>clear
cam-w cam-h GL_RGBA new-textbuffer to scan-fb-raw ;
: new-scantex ( -- )
scan-tex 0>clear
scan-w 2* dup GL_RGBA new-textbuffer to scan-fb ;
: new-scantex-final ( -- )
scan-tex-final 0>clear
scan-w 2* dup GL_RGBA new-textbuffer to scan-fb-final ;
: new-scantexes ( -- )
scan-fb 0= IF
new-scantex-raw new-scantex new-scantex-final 0>framebuffer
THEN ;
: 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-scl sf!
p0 2@ p2 2@ p- p1 2@ p3 2@ p- p+ p2/
s>f y-scansize f/ y-scl 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-xy ( -- sx sy )
1e cam-h cam-w over umin swap fm*/
1e cam-w cam-h over umin fm*/ ;
: scan-legit ( -- ) \ resize a legit QR code
clear init-scan' set-scan' >scan-matrix
scan-matrix MVPMatrix set-matrix
scan-matrix MVMatrix set-matrix
scan-tex-raw linear-mipmap 0 scan-xy draw-scan scan-grab1 ;
: scan-legit? ( -- addr u flag )
[IFDEF] distdebug
dist0 off dist0-max off dist0-min on
dist1 off dist1-max off dist1-min on
[THEN]
scan-legit >guess
>guessecc tag@ guesstag c!
2dup guessecc $10 ecc-ok? ;
Create sat%s 1.0e sf, 1.666e sf, 1.333e sf, 2.0e sf,
does> ( n -- ) swap sfloats + sf@ ;
: tex-frame ( -- )
program init-program set-uniforms
unit-matrix MVPMatrix set-matrix
unit-matrix MVMatrix set-matrix ;
: draw-scaled ( i -- )
3 and sat%s saturate% sf!
Saturate 1 saturate% glUniform1fv
tex-frame scan-w 2* dup scan-fb >framebuffer
scan-tex-raw linear-mipmap 0 scan-xy draw-scan
scan-grab0 scan-w 2* dup scan-fb-final >framebuffer ;
: sat-reset ( sat -- )
saturate% sf! Saturate 1 saturate% glUniform1fv ;
previous
[IFDEF] android
require android/qrscan-android.fs
also android
[ELSE]
[IFDEF] linux
require linux/qrscan-linux.fs
[THEN]
[THEN]
[IFUNDEF] scan-result
: scan-result ( addr u tag -- )
qr( >r
bounds ?DO ." qr : " I $10 xtype cr $10 +LOOP
r> ." tag: " dup hex. cr
." ecc: " guessecc $10 xtype cr
[IFDEF] distdebug
." dist/min/max: "
dist0 @ s>f [ 18 18 * ]L fm/ f>s . dist0-min ? dist0-max ? space
dist1 @ s>f [ 18 18 * ]L fm/ f>s . dist1-min ? dist1-max ? cr
[THEN]
) ;
[THEN]
: adapt-rgb ( -- )
scan-buf0 $@ get-minmax-rgb { d: r d: g d: b }
b over - 2/ 2/ + to blue-level# \ blue level is 1/4 of total
g over - 2 5 */ + to green-level# \ green at 40% of total
r over - 2/ + to red-level# ; \ red at 50% of total
: scan-it ( -- )
search-corners
?legit IF scan-legit? IF
guessecc $10 + c@ scan-result qr( ." took: " .time cr )
qr( save-png1 1 +to scan# )
ELSE 2drop THEN
THEN ;
: scan-once ( -- )
saturate% sf@ { f: sat }
draw-cam qr( !time ) 3 0 DO
I draw-scaled adapt-rgb
7 to rgb-xor scan-it
0 to rgb-xor scan-it
LOOP sat sat-reset
ekey? IF ekey dup k-volup = swap bl = or IF save-pngs THEN THEN ;
: scan-loop ( -- )
1 level# +!@ >r BEGIN scan-once >looper level# @ r@ <= UNTIL
rdrop ;
: scan-qr ( -- )
[IFDEF] lastscan$ lastscan$ $free [THEN]
scan-start ['] scan-loop catch level# off
cam-end 0>framebuffer
[IFDEF] saturate% 1.0e saturate% sf! [THEN]
[IFDEF] showstatus showstatus [THEN]
[IFDEF] terminal-program terminal-program terminal-init [THEN]
dup IF
." Scan failed" cr
ELSE
." Scan completed" cr
THEN
throw ;
previous
:noname ( -- )
?get-me init-client
?nextarg IF s" -many" str= 0= ELSE true THEN to scan-once?
scan-qr ; is run-scan-qr
\\\
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:
[THEN]