#!/usr/bin/sbcl --script

(defpackage #:virtual1
  (:use :cl))

(in-package #:virtual1)

(defun byte-not (b)
  (logand (lognot b) #xFF))

(defun rol64 (value count)
  (let* ((count (mod count 64))
         (value (ldb (byte 64 0) value)))
    (ldb (byte 64 0)
         (logior (ash value count)
                 (ash value (- count 64))))))

(defun string-popcount (str)
  (loop for ch across str sum (logcount (char-code ch))))

(defun hex-digit-p (ch)
  (let ((code (char-code ch)))
    (or (and (>= code 48) (<= code 57))      ; 0-9
        (and (>= code 65) (<= code 70)))))   ; A-F 
       

(defun crackhash (state ch)
  (let* ((val (char-code ch))
         (popcnt (logcount val))
         (rotated (rol64 state popcnt))
         (param (if (oddp popcnt)
                    (byte-not val)
                    val)))
    (logxor rotated param)))

(defun gen-pwd (username)
  (loop for ch across username
        unless (hex-digit-p ch)
        do (error "Username contains invalid char: ~A" ch))
  
  (let* ((u-len (length username))
         (pop-sum (mod (string-popcount username) 256)))  
    
    (let ((prefix (format nil "~2,'0X~2,'0X-" u-len pop-sum)))
      
      (let ((state #xB7E151628AED2A6A))
        (loop for ch across username
              do (setf state (crackhash state ch)))
        
        (concatenate 'string prefix (format nil "~16,'0X" state))))))

(defun read-username ()
  (format *query-io* "Enter username (hex digits only): ")
  (force-output *query-io*)
  (string-trim '(#\Space #\Tab #\Newline) (read-line *query-io*)))

(defun main ()
  (handler-case
      (let ((username (read-username)))
        (when (string= username "")
          (error "Username cannot be empty"))
        (let ((password (gen-pwd username)))
          (format t "~A~%" password)))
    (error (e)
      (format *error-output* "~A~%" e)
      (format *error-output* "Usage: Provide a username consisting of hex digits (0-9, A-F)~%")
      (sb-ext:exit :code 1)))
  (sb-ext:exit :code 0))

(main)